Excel VBAループの名前のリストによるシートの一部を介して

Question

私はテーブルの中の会社の名前のリストを持っており、私はこのリストでデータシートに、会社名とシートを移動し、表。私は、各comapnyのためにそれを15回するコードを作りました、そして、私は誰が私に特定のシートを検索し、私が必要とするデータをコピーする特定のループを見つけることができるかに幸運になります。ここ

は各シートに15のコードの2のサンプルです：

Sheets("Comapny1").Activate 
Range("H2").End(xlDown).Select 
Range(Selection, Selection.End(xlToRight)).Copy 
Sheets("Data").Activate 
Range("A2", Range("A2").End(xlDown)).Find("Comapny1").Activate 
ActiveCell.Offset(0, 1).PasteSpecial (xlPasteValues) 

Sheets("Comapny2").Activate 
Range("H2").End(xlDown).Select 
Range(Selection, Selection.End(xlToRight)).Copy 
Sheets("Data").Activate 
Range("A2", Range("A2").End(xlDown)).Find("Comapny2").Activate 
ActiveCell.Offset(0, 1).PasteSpecial (xlPasteValues) 

Answer 1

Option explicit 

Sub LoopThroughCompanies() 

    Dim Company as Range 
    Dim Companies as Range 

    Set Companies = Thisworkbook.Worksheets(NameOfSheetWithCompaniesOnIt).range(TableName[ColumnName]) 

    For each Company in Companies 
     With thisworbook.worksheets(company.value2) 
      .activate 
      .Range("H2").End(xlDown).Select 
      .Range(Selection, Selection.End(xlToRight)).Copy 
     End with 
     With thisworkbook.workSheets("Data") 
      .Activate 
      .Range("A2", .Range("A2").End(xlDown)).Find(company.value2,,xlvalues,xlwhole,).Activate 
      ActiveCell.Offset(0, 1).PasteSpecial (xlPasteValues) 
     End with 
    Next Company 

End sub 

これを試してみてください

携帯電話で未テストで書かれています。フォーマットが正しくないと申し訳ありません。あなたはactivate/selectを使うべきではありませんが、動作していることが分かっていれば元のコードをあまりにも編集したくありませんでした。

あなたのワークブックごとに、NameOfSheetWithCompaniesOnItを実際の名前に置き換えてください。

ブック名[ColumnName]は、ワークブックごとに実際のテーブル名とカラム名に置き換えてください。

希望します。

Answer 2

は、シート名とあなたは企業のリストを持っている範囲を変更した後

Sub test() 

    Dim companies As Range 
    Dim cell As Range 

    Set companies = Sheets("CompnayNamesSheet").Range("A1:A10") 

    For Each cell In companies 

     Sheets(cell.Value).Activate 
     Range("H2").End(xlDown).Select 
     Range(Selection, Selection.End(xlToRight)).Copy 

     Sheets("Data").Activate 
     Range("A2", Range("A2").End(xlDown)).Find(cell.Value).Activate 
     ActiveCell.Offset(0, 1).PasteSpecial (xlPasteValues) 

    Next cell 

End Sub