range copy from a column to new sheet in adjacent columns till blank cells in a loop in excel-CodePudding

I have a excel file with more than 80000 lines/values in a column. After random lines/values a blank cell is present. I want to copy all values above every blank cell to a new column in another workbook. I have tried the following,

Sub main()

Dim wba As Workbook
Dim wbb As Workbook

Set wba = Workbooks("test.xlsx")
Set wbb = Workbooks("test1.xlsx")

With wba.Worksheets("Sheet1")
      .Range("BA2", .Range("A2").End(xlDown)).Copy
End With

wbb.Worksheets("Sheet1").Range("A2").PasteSpecial xlPasteValues

End Sub

But this is copying till the occurrence of first blank cell only. I want to run it in a loop till the end of column so that if blank cell appears for say 100 times then I will have 100 columns in test1.xlsx.

The sample data is:

A
10
20
30
4045
85

98
87
54
65

9
110
335
995
664
256

22
44

55
66
77

The intended output in another workbook is :

A	B	C	D	E
10	98	9	22	55
20	87	110	44	66
30	54	335		77
4045	65	995
85		664
		256

CodePudding user response：

Untested, but give this a try. Areas captures each block of cells separated by blanks. If your cells contain formulas this code will need to use xlCellTypeFormulas instead of xlCellTypeConstants.

Sub main()

Dim wba As Workbook
Dim wbb As Workbook
Dim r As Range, c As Long

Set wba = Workbooks("test.xlsx")
Set wbb = Workbooks("test1.xlsx")

With wba.Worksheets("Sheet1")
      For Each r In .Columns(1).SpecialCells(xlCellTypeConstants).Areas
        c = c   1
        r.Copy
        wbb.Worksheets("Sheet1").Cells(2, c).PasteSpecial xlPasteValues
    Next r
End With

End Sub