Скопируйте три столбца в один столбец в Excel VBA

Question

Мне нужна помощь для создания макроса Excel VBA. У меня есть книга, содержащая 4 листа. Coulmn «A» на листе № 1, 2 и 3 заполнены данными. Мне нужно скопировать эти данные в колонку 4 «4». Я уже сделал это, используя этот код, но он не работает (он копирует только данные, заменяя ..).

Пример (мне нужно сделать следующее)

(Sheet 1 Col. A) 
1 
2 
3 
4 

(Sheet 2 Col. A) 
5 
6 

(Sheet 3 Col. A) 
7 
8 
9 

нужно скопировать все выше в листе 4 Col. А, как следует

1 
2 
3 
4 
5 
6 
7 
8 
9 

Итак, я написал код следующим

Sub CopyColumnToWorkbook() 
    Dim sourceColumn As Range, targetColumn As Range 

    Set sourceColumn = Worksheets("Sheet1").Columns("A") 
    Set targetColumn = Worksheets("Sheet4").Columns("A") 

    sourceColumn.Copy Destination:=targetColumn 
End Sub 

Sub CopyColumnToWorkbook2() 

    Dim sourceColumn As Range, targetColumn As Range 

    Set sourceColumn = Worksheets("Sheet2").Columns("A") 
    Set targetColumn = Worksheets("Sheet4").Columns("A") 

    sourceColumn.Copy Destination:=targetColumn 
End Sub 

Sub CopyColumnToWorkbook2() 

    Dim sourceColumn As Range, targetColumn As Range 

    Set sourceColumn = Worksheets("Sheet3").Columns("A") 
    Set targetColumn = Worksheets("Sheet4").Columns("A") 

    sourceColumn.Copy Destination:=targetColumn 
End Sub 

Это вышеописанное кодирование не работает, как мне нужно. Кто-то, пожалуйста, помогите мне сделать это, как в приведенном выше примере.

спасибо.

Answer 1

Это быстрый код, который я собрал, чтобы вы попали на правильный путь. Его можно очистить. В основном вы хотите просмотреть каждый лист и посмотреть, что используется последним столбцом, а затем скопировать весь использованный диапазон для столбца A и вставить его на главный лист, начиная с последней ячейки, используемой в столбце A. Вы не хотите вставить целые столбцы, так что я использовал «End (xlUp)», которые находят последнюю ячейку, используемую в столбце A.

Sub ColumnAMaster() 

Dim lastRow As Long, lastRowMaster As Long 
Dim ws As Worksheet 
Dim Master As Worksheet 

Application.ScreenUpdating = False 
Set Master = Sheets.Add 
Master.Name = "Master" 
lastRowMaster = 1 

For Each ws In ThisWorkbook.Sheets 
    If ws.Name <> "Master" Then 
     lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row 
     ws.Range("A1:A" & lastRow).Copy Destination:=Master.Range("A" & lastRowMaster) 
     lastRowMaster = Master.Range("A" & Rows.Count).End(xlUp).Row + 1 
    End If 
Next 

Application.ScreenUpdating = True 
MsgBox "Done!" 

End Sub 

к сожалению StackOverflow не отступы код, как он должен ...

вещей, которые вы может потребоваться: проверьте, нет ли каких-либо данных на каждом листе перед копированием A в мастер, проведите листы по листам в определенном порядке, проверьте, существует ли «главный» лист или нет, и т. д.

Answer 2

Вот еще один способ, очень быстрый и простой, но делает работу
Вы могли бы, очевидно, объединить все из них 3 делают петли в одну петлю

Dim x As Integer 
Dim y As Integer 

x = 1 
y = 1 

Do Until Worksheets("Sheet1").Range("A" & x) = "" 
    Worksheets("Sheet4").Range("A" & y) = Worksheets("Sheet1").Range("A" & x) 
    y = y + 1 
    x = x + 1 
Loop 

x = 1 
Do Until Worksheets("Sheet2").Range("A" & x) = "" 
    Worksheets("Sheet4").Range("A" & y) = Worksheets("Sheet2").Range("A" & x) 
    y = y + 1 
    x = x + 1 
Loop 

x = 1 
Do Until Worksheets("Sheet3").Range("A" & x) = "" 
    Worksheets("Sheet4").Range("A" & y) = Worksheets("Sheet3").Range("A" & x) 
    y = y + 1 
    x = x + 1 
Loop