2

親愛なるスタック オーバーフロー スウォーム。

ファイル「Prodcuts.xlmx」には、ワークシート「Contract1」の列 A に数千の数値があります。同じファイルには、「Contract2」などの名前の類似したワークシートがいくつか含まれています。行数は各ワークシートで変化し、時間の経過とともに同じワークシートでも変化する可能性がありますが、常に空の行が続きます。ワークシートの数は静的です

これらのワークシートの情報を 2 番目のファイルから 1 つのワークシートに収集する必要があります。列 A にワークシート名の繰り返しが含まれ、列 B に数値が含まれる形式で「製品リスト」と呼びましょう。

変更の可能性について複数回のチェックを避けるために、この情報を単純にコピーする抽出ループを使用したいと思います。

空のセルの後に必要のない追加のデータセットが来るため、ソースをコピーするために列を選択することはできません。

一般的な考え方は

WS1 列 A の内容を取得し、空行になるまで、「製品リスト」列 B にコピーします

WS1 WS 名を取得し、「製品リスト」列 A にコピーし、列 B に値がなくなるまで繰り返します (または列 B +1 行に値がなくなるまで、WS 名の余分な行を避けるため)

空行を2つ追加

WSn が存在しなくなる (または一致カウントがなくなる) まで、WS2 について繰り返します。

4

1 に答える 1

0

他の投稿で同様の回答をしましたが、少し修正しました。ケースに合わせてカスタマイズ

Sub testing()
Dim resultWs As Worksheet
Dim ws As Worksheet
Dim dataArray As Variant
Dim height As Long
Dim currentHeight As Long
Dim wsName As String
Set resultWs = Worksheets("Productlist")
For Each ws In Worksheets
    If InStr(ws.Name, "Contract") Then
        With ws
            wsName = .Name
            height = .Cells(1, 1).End(xlDown).Row 'look til empty row
            If height > 1048575 Then
                height = 1
            End If

            ReDim dataArray(1 To height, 1 To 1)
            dataArray = .Range(.Cells(1, 1), .Cells(height, 1)).Value

        End With

        With resultWs
            currentHeight = .Cells(.Rows.Count, 1).End(xlUp).Row
            If .Cells(1, 1) = "" Then
                currentHeight = 0
            End If
            If VarType(dataArray) <> vbDouble Then
                .Range(.Cells(currentHeight + 1, 1), .Cells(currentHeight + UBound(dataArray, 1), 1)).Value = wsName
                .Range(.Cells(currentHeight + 1, 2), .Cells(currentHeight + UBound(dataArray, 1), 2)).Value = dataArray
            Else
                .Cells(currentHeight + 1, 1).Value = wsName
                .Cells(currentHeight + 1, 2).Value = dataArray
            End If

        End With
    End If

Next ws

End Sub
于 2012-11-07T10:35:07.827 に答える