☰

VBA: 新しい行を作成し、異なるシートからのデータで自動入力する

tag-icon • tag-icon microsoft-excel vba microsoft-excel-2016
VBA: 新しい行を作成し、異なるシートからのデータで自動入力する

以下の情報が記載されたシートが 2 枚あります。

シートB
アイテム1
アイテム2

シートC
場所A
場所B
場所C

そして、SheetA に以下の結果を表示しようとしています。

シートA
アイテム1 場所
A アイテム1 場所
B アイテム1場所C
アイテム2 場所A
アイテム2 場所B
アイテム2 場所C

この VBA コードを使用して、SheetB から SheetA にアイテムをコピーしますが、各アイテムは異なる場所に保存される可能性があるため、SheetB の各アイテムと、SheetC にリストされている可能性のあるすべての場所を SheetA にリストしたいと思います。SheetA の目的は、すべての情報をまとめることです。

Worksheets("SheetB").ListObjects("ArtikelDBTable").ListColumns("ARTIKEL").DataBodyRange.Copy _
Destination:=Worksheets("SheetA").ListObjects("WerbemittelTable").ListColumns("ARTIKEL").DataBodyRange

ありがとう。

答え1

私が見つけた解決策は次のとおりです:

Sub Makro1()

    Dim i As Long
    Dim ii As Long
    Dim i3 As Long
    Dim i4 As Long
    Dim LastRowSht2 As Long
    Dim LastRowSht3 As Long
    Dim wb As Workbook
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet

    Set wb = ThisWorkbook
    Set sht1 = wb.Sheets("Tabelle1")
    Set sht2 = wb.Sheets("Tabelle2")
    Set sht3 = wb.Sheets("Tabelle3")

    'Find the last row (in column A) with data.
    LastRowSht2 = sht2.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
    LastRowSht3 = sht3.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
    ii = 2
    i4 = 2

    For i = 2 To LastRowSht2

        For i3 = 2 To LastRowSht3
            sht1.Range("A" & ii) = sht2.Range("A" & i).Value
            sht1.Range("B" & ii) = sht3.Range("A" & i4).Value
            ii = ii + 1
            i4 = i4 + 1
        Next i3
        i4 = 2
    Next i
 End Sub

関連情報