Adapt VBA Code With Adjusment Range

[muhammad susanto]

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


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

[muhammad susanto]

if you are confused. i attach new workbook with show the results completely...

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

[Admin]

Hi

May be..


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