Thread: Macro to pull data from sheet1 to sheet2

hi rupss01, please check attachment, run code "test"

Option Explicit
Sub test()

Dim data, result, n As Long, j As Long, i As Long, icounter As Long, addr As String, x As Long


With Sheets("Sheet1")
    If .Range("a1") = "" Then Exit Sub
    data = .Range("a1", .Cells(Rows.Count, "a").End(xlUp))
End With

ReDim result(1 To UBound(data) / 12, 1 To 7)

For n = 1 To UBound(data) Step 12
    
    j = j + 1
    
    i = n
    
    icounter = icounter + 1
    result(j, 1) = icounter
    
    result(j, 2) = data(i, 1)
    
    addr = data(i + 1, 1) & ", "
    
    i = i + 2
    
    Do
        
         addr = addr & data(i, 1)
        
        i = i + 1
        
        If data(i, 1) = "" Then Exit Do
        
    Loop Until InStr(1, data(i, 1), "-") > 0
    
    x = InStrRev(addr, ",")
    
    result(j, 3) = Mid(addr, 1, x - 1)
    
    result(j, 4) = Mid(addr, x + 2, Len(addr))
    
    result(j, 5) = data(i, 1)
    
    result(j, 6) = CInt(Split(data(i + 6, 1), " ")(0))
    
    result(j, 7) = CInt(Split(data(i + 7, 1), " ")(0))
    
    addr = ""
    
Next

If j > 0 Then Sheets("Sheet2").Cells(Rows.Count, "a").End(xlUp).Offset(1).Resize(j, 7) = result

End Sub

if assume that three row address will look like rows 1-12 sample of the attachment, it might be done like this

Option Explicit
Sub test()

Dim data, result, n As Long, j As Long, i As Long, icounter As Long, addr As String, x As Long, zctrl As Integer, corr As Integer


With Sheets("Sheet1")
    If .Range("a1") = "" Then Exit Sub
    data = .Range("a1", .Cells(Rows.Count, "a").End(xlUp))
End With

ReDim result(1 To UBound(data) / 12, 1 To 7)

For n = 1 To UBound(data) Step 12
    
    j = j + 1
    
    i = n
    
    icounter = icounter + 1
    result(j, 1) = icounter
    
    result(j, 2) = data(i, 1)
    
    addr = data(i + 1, 1)
    
    i = i + 2
    
    zctrl = 1
    
    Do
        
        addr = addr & ", " & data(i, 1)
        
        zctrl = zctrl + 1
        
        i = i + 1
        
        If data(i, 1) = "" Then Exit Do
        
    Loop Until InStr(1, data(i, 1), "-") > 0
    
    If zctrl = 3 Then corr = 1 Else corr = 0
    
    x = InStrRev(addr, ",")
    
    result(j, 3) = Mid(addr, 1, x - 1)
    
    result(j, 4) = Mid(addr, x + 2, Len(addr))
    
    result(j, 5) = data(i, 1)
    
    result(j, 6) = CInt(Split(data(i + 6 - corr, 1), " ")(0))
    
    result(j, 7) = CInt(Split(data(i + 7 - corr, 1), " ")(0))
    
    addr = ""
    
Next

If j > 0 Then Sheets("Sheet2").Cells(Rows.Count, "a").End(xlUp).Offset(1).Resize(j, 7) = result

End Sub

@watersev...the code works perfects...thanks for your prompt response.

One query can i pull more than 100 data @ time

the code has no such limitation provided the layout will be the same

if you are happy with the solution provided, please mark the thread as Solved under Forum rules:

If your problem is solved, please say so clearly, and mark your thread as Solved: Click the Edit button on your first post in the thread, Click Go Advanced, select [SOLVED] from the Prefix dropdown, then click Save Changes. If more than two days have elapsed, the Edit button will not appear -- ask a moderator to mark it.

@watersev

Bro can you please check attached file as well, while running macro getting Runtime Error 13 - Type mismatch

Unable to pull more than 12 data...

Surely will follow your's instruction.

@watersev

Also some instance Runtime Error 9- Subscript out of Range

Also some instance Runtime Error 9- Subscript out of Range

@watersev

thanx a lot for your time and efforts ...instruction followed