Results 1 to 3 of 3

Thread: Adapt VBA Code With Adjusment Range

  1. #1
    Member
    Join Date
    Sep 2013
    Posts
    37
    Rep Power
    0

    Adapt VBA Code With Adjusment Range

    hii expert...

    would you help me to easy adapt this code which expected result in "sheet2" start from range "k16" drop down
    with source data in sheet "data" and with title/column name as parameter...

    i confused to figure it out, and i 'am newbie

    Code:
    Sub result()
    Dim lstRow As Long
    Dim i As Long
    Application.ScreenUpdating = False
    Sheet2.Range("B2:C500").Value = "" 'Change as required
    Sheet1.Activate
    lstRow = Range("C" & Rows.Count).End(xlUp).Row
    For i = 2 To lstRow
        If Range("C" & i).Value <> "" Then
        Sheet2.Cells(Rows.Count, Range("B1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("C" & i).Value
        End If
        If Range("D" & i).Value <> "" Then
        Sheet2.Cells(Rows.Count, Range("C1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("D" & i).Value
        End If
        If Range("E" & i).Value <> "" Then
        Sheet2.Cells(Rows.Count, Range("B1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("C" & i).Value
        Sheet2.Cells(Rows.Count, Range("C1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("e" & i).Value
        End If
        If Range("F" & i).Value <> "" Then
        Sheet2.Cells(Rows.Count, Range("B1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("C" & i).Value
        Sheet2.Cells(Rows.Count, Range("C1").Column).End(xlUp).Offset(1, 0).Value _
        = Sheet1.Range("F" & i).Value
        End If
        If Range("D" & i).Value = "" Then
        Sheet2.Cells(Rows.Count, Range("C1").Column).End(xlUp).Offset(1, 0).Value _
        = "-"
        End If
    Next i
    Sheet2.Activate
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "I think now you are happy after see your desired Answer" 
    End Sub
    for anybody help me, much appreciated...
    i attach woorbook


    regards..
    m.susanto
    Attached Files Attached Files

  2. #2
    Member
    Join Date
    Sep 2013
    Posts
    37
    Rep Power
    0
    if you are confused. i attach new workbook with show the results completely...

    i hope somebody would help me to make me happy......
    Attached Files Attached Files

  3. #3
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi

    May be..

    Code:
    Sub kTest()
        
        Dim rngData     As Range
        Dim rngName     As Range
        Dim rngDest     As Range
        Dim r           As Long
        Dim c           As Long
        Dim p           As Long
        Dim Ofset       As Long
        
        Ofset = 7
        
        With Sheet1
            p = .Range("c" & .Rows.Count).End(xlUp).Row
            Set rngName = .Range("c2:c" & p)
            Set rngData = .Range("aj2:at" & p)
        End With
        
        Set rngDest = Sheet2.Range("d32")
        
        For r = 1 To rngName.Rows.Count
            If Not rngName.Cells(r, 1).Value = vbNullString Then
                rngDest = rngName.Cells(r, 1)
                For c = 1 To rngData.Columns.Count
                    If Not rngData.Cells(r, c).Value = vbNullString Then
                        rngDest.Offset(, Ofset) = rngData.Cells(r, c).Value2
                        rngDest = rngName.Cells(r, 1)
                        Set rngDest = rngDest.Offset(1)
                    Else
                        If c = 1 Then Set rngDest = rngDest.Offset(1)
                        Exit For
                    End If
                Next
            End If
        Next
        
    End Sub
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

Similar Threads

  1. data entry to correct cell range...code needs help
    By paul_pearson in forum Excel Help
    Replies: 2
    Last Post: 08-28-2013, 05:26 PM
  2. Replies: 1
    Last Post: 08-23-2013, 06:33 PM
  3. Shorten VBA Code By Removing Redundant Superfluous Code
    By paul_pearson in forum Excel Help
    Replies: 2
    Last Post: 08-15-2013, 09:09 PM
  4. VBA Looping Input Range and Output Range
    By Whitley in forum Excel Help
    Replies: 7
    Last Post: 04-25-2013, 09:02 PM
  5. Replies: 3
    Last Post: 01-28-2013, 11:01 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •