Excel VBAのコピー行が自動的に

Question

行を特定のシートにコピーする自動メソッドを作成するには、助けが必要です。

私は5分ごとにこのシートにデータをインポートするWEB APIクエリを持つタブ（Sales）を持っています。セールスシートには、各商品を識別する名前の範囲を持つ行があります。行には100の異なる名前があり、ブック内に同じ名前で100枚のシートが作成されています。

各アイテムの行全体をコピーして、アイテムと同じ名前のシートにコピーしたいとします。

これは、コピーサブオフ火災にある：私は自動的に行をコピーする方法についての多くの方法を見てきましたが、私はコピー行に支援し、項目名を使用し、他のシートに貼り付ける必要がある

'Copy Sales data Every 10 Min 
Sub test() 
    'Application.OnTime Now + TimeValue("00:10:00"), "my_Procedure…" 
End Sub 

を同じ名前で

Answer 1

ここに私がコメントで説明したものの概要はありません。ここでは、名前付き範囲のリストはセルJ3からNamesSheetに始まります。画像では、私は同じシート（簡略化のためにSourceSheet）にそれを示しています。リストは配列に読み込まれ、配列はループされて値を設定する適切なシートを選択します。

コピーして貼り付けるのではなく、ターゲットの行（次に使用できる行）を設定します。ソース行（copyRow）に等しい配列インデックス。 Withステートメントは、対象シートの選択を避けるために使用されます（より効率的です）。

現在、欠落しているシートに対してエラー処理が追加されていません。

シートに100個の名前付き範囲のリストがあるとは考えていません。そうしないと、最初から配列のサイズを設定できました。販売]タブのコーラで

名前付き範囲：名での名前付き範囲の

一覧シート（省略）

Option Explicit 

Private Sub myProc() 

Dim wb As Workbook 
Dim wsSource As Worksheet 
Dim wsNames As Worksheet 

Set wb = ThisWorkbook 
Set wsSource = wb.Worksheets("Sales") 
Set wsNames = wb.Worksheets("Names") 

Dim namesArr() 
namesArr = wsNames.Range("J3:J" & wsNames.Cells(wsNames.Rows.Count, "J").End(xlUp).Row).Value 

If UBound(namesArr, 1) <> wsSource.Range("ITEMName").Rows.Count Then 
    MsgBox "There are not a matching number of named ranges listed in Names sheet." 
    Exit Sub 
End If 

Dim i As Long 
Dim currLastRow As Long 
'Any optimization code could actually go in outer calling sub but consider 
'some such as the following 

Application.ScreenUpdating = False 
Dim copyRow As Range 

For i = LBound(namesArr, 1) To UBound(namesArr, 1) 

    With wb.Worksheets(namesArr(i, 1)) 

    Set copyRow = wsSource.Range(namesArr(i, 1)).EntireRow 

    If IsEmpty(.Range("A1")) Then 'First row in sheet is available 

     .Rows(1).Value = copyRow.Value2 

    Else 

     currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 

     .Rows(currLastRow + 1).Value = copyRow.Value2 

    End If 

    End With 

Next i 

Application.ScreenUpdating = True 

End Sub 

バージョン2：

Salesの名前付き範囲をループする（シート内の101の名前付き範囲のみを想定し、ワークブックの範囲でテストし、ITEMNameと呼ばれるこれらのうちの1つを無視します。アプローチは@user1274820から適合しました。

Option Explicit 

Private Sub myProc2() 

    Dim wb As Workbook 
    Dim wsSource As Worksheet 

    Set wb = ThisWorkbook 
    Set wsSource = wb.Worksheets("Sales") 

    Dim currLastRow As Long 
    'Any optimization code could actually go in outer calling sub but consider 
    'some such as the following 

    Application.ScreenUpdating = False 

    Dim copyRow As Range 
    Dim nm As Variant 

    For Each nm In ThisWorkbook.Names 

     If nm.RefersToRange.Parent.Name = "Sales" And nm.Name <> "ITEMName" Then 

      With wb.Worksheets(nm.Name) 

       Set copyRow = wsSource.Range(nm.Name).EntireRow 

       If IsEmpty(.Range("A1")) Then 'First row in sheet is available 

        .Rows(1).Value = copyRow.Value2 

       Else 

        currLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 

        .Rows(currLastRow + 1).Value = copyRow.Value2 

       End If 

      End With 

     End If 

    Next nm 

    Application.ScreenUpdating = True 

End Sub