Merge Multiple column in next sheet

[dingdang]

I have worksheet having co. name wise data in to 2 columns 'Advise no' and 'Amount',

I want to merge all co.name wise data in to next sheet. attached file for your ref.

( column and data r not fixed )


Pls help.


https://dl.dropbox.com/u/66400357/Merge%20Column.xlsx

 

[mercatog]

Hi

Test this code

[pre]

Sub Test()
Dim LastCol As Integer, i As Integer
Dim Sh As Worksheet
Dim LastLig As Long

Application.ScreenUpdating = False
With Worksheets("Sheet1")
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set Sh = Worksheets("Sheet3")
Sh.UsedRange.Clear
Sh.Range("A2:C2") = Array("co name", "Advice #", "Amount")
For i = 2 To LastCol Step 2
LastLig = .Cells(.Rows.Count, i).End(xlUp).Row
Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2).Resize(LastLig - 5, 1) = .Cells(2, i)
.Range(.Cells(6, i), .Cells(LastLig, i + 1)).Copy Sh.Cells(Sh.Rows.Count, 2).End(xlUp)(2)
Next i
Set Sh = Nothing
End With
End Sub

[/pre]

Regards,

 

[dingdang]

Sir,


Perfect.. Many thanks!!


But one more modification required. i forgot in my first post. if any co. name is blank(2 columns ) between then this blank column should ignore and next 2 column should copy in continue.


in above code if blank column in sheet it stuck macro stuck with below line.


Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2).Resize(LastLig - 5, 1) = .Cells(2, i)


sorry for the incomplete info.

 

[mercatog]

We need to check if LastLig >5. The code wille be:

[pre]

Sub Test()
Dim LastCol As Integer, i As Integer
Dim Sh As Worksheet
Dim LastLig As Long

Application.ScreenUpdating = False
With Worksheets("Sheet1")
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set Sh = Worksheets("Sheet3")
Sh.UsedRange.Clear
Sh.Range("A2:C2") = Array("co name", "Advice #", "Amount")
For i = 2 To LastCol Step 2
LastLig = .Cells(.Rows.Count, i).End(xlUp).Row
If LastLig > 5 Then
Sh.Cells(Sh.Rows.Count, 1).End(xlUp)(2).Resize(LastLig - 5, 1) = .Cells(2, i)
.Range(.Cells(6, i), .Cells(LastLig, i + 1)).Copy Sh.Cells(Sh.Rows.Count, 2).End(xlUp)(2)
End If
Next i
Set Sh = Nothing
End With
End Sub

[/pre]

 

[dingdang]

Yes, its work. Thanks a lot.