1

複数のシートとデータ (6 列のブロック) を含む複数の列を含む xls ファイルがあります。このデータを最後のシートの下にある最後のシートにコピーする必要があります。

つまり、次のようになります。

あいうえお

あいうえお

あいうえお

最後のシートで次のようにしたいと思います。

a

a

a

b

b

b

c

c

c

d

d

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
4

1 に答える 1

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
于 2012-08-29T10:36:10.423 に答える