Question

我的xls文件包含多个工作表和多个包含数据的列（以6列为单位）。我必须将这些数据复制到最后一张，每张都在最后一张。

换句话说，它现在看起来像这样：

a b c d

我想在最后一张表中看起来像这样：

一

B'/ P>

C

d

我设法创建了从每张工作表中复制前6列的宏，但是我不能创建一个循环来遍历每张工作表中的列：

Sub kopiuj_wszystko()

Dim kolumna As Integer
For Each oWBK In ThisWorkbook.Worksheets
For j = 1 To 1000
If oWBK.Name <> "podsumowanie" Then
' Kopiuj

oWBK.Select

x = Range(j & "1000").End(xlUp).Row 'sprawdź ilość wypełnionych wierszy
y = 6 'ogranicz do kolumny F
oWBK.Cells(x, y).Select
Z = ActiveCell.Address
Range("A9", Z).Select
'Application.CutCopyMode = False
Selection.Copy

'Wklej
Sheets("podsumowanie").Select
E = Range("c10000").End(xlUp).Row
R = 3
Sheets("podsumowanie").Cells(E, R).Select

ActiveSheet.Paste

'Kopiuj kategorię
oWBK.Select
T = Range("A1").Value
Application.CutCopyMode = False
Selection.Copy

'Wklej kategorię
w = 1
Sheets("podsumowanie").Select
Sheets("podsumowanie").Cells(E, w).Select
L = ActiveCell.Address
Range(L).Value = T

'Kopiuj index
oWBK.Select
T = Range("C3").Value
Application.CutCopyMode = False
Selection.Copy

'Wklej index
w = 2
Sheets("podsumowanie").Select
Sheets("podsumowanie").Cells(E, w).Select
L = ActiveCell.Address
Range(L).Value = T

End If
Next j

Next oWBK

End Sub

Answer 1

这里的代码非常简单，无论有多少列都可以使用：（循环遍历每个单元格（数据量较大时速度较慢）

Sub ColumnsToOne()

Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Sheet2")
Dim x As Long
Dim y As Long
Dim z As Long

z = 1
For Each wsF In ThisWorkbook.Sheets
x = 1
y = 1
If wsF.Name <> wsT.Name Then
    Do While Len(wsF.Cells(x, y)) <> 0
        Do While Len(wsF.Cells(x, y)) <> 0
            wsF.Cells(x, y).Copy wsT.Cells(z, 1): z = z + 1: x = x + 1
        Loop
        x = 1: y = y + 1
    Loop
End If
Next

End Sub

以下代码复制每个范围并将其添加到工作表中：（使用大数据集更快）

Sub CopyColumnsToOne()
Dim wsT As Worksheet: Set wsT = ThisWorkbook.Sheets("Sheet2")
Dim y As Long
For Each wsF In ThisWorkbook.Sheets
    If wsF.Name <> wsT.Name Then
        For y = 1 To 6
            wsF.Range(wsF.Cells(1, y), wsF.Cells(wsF.Cells(wsF.Rows.Count, y).End(xlUp).Row, y)).Copy wsT.Cells(wsT.Range("A65536").End(xlUp).Row + 1, 1)
        Next
    End If
Next
End Sub

VBA检查不同列中的范围

1 个答案: