すべてのシート名を含む名前付き範囲を参照するループにVBAが必要

Question

あるシートのデータを別のシートにコピーする「原油」コードがあり、データがコピーされたシート名が見つかります細胞内でしかし、シートの枚数が増えていて、シート名にダイナミックな名前付き範囲が作成されており、ダイナミックレンジ内のすべてのシートに対して次のコードを実行したいと考えています。私のコードは次のようになります。

Calculate 

' get the worksheet name from cell AA3 
Worksheets(Range("AA3").Value).Activate 

' Copy the data 
Range("A1:A1500").Select 
Selection.Copy 

' Paste the data on the next empty row in sheet "Artiklar" 
Sheets("Artiklar").Select 
Dim NextRow As Range 
Set NextRow = Range("A65536").End(xlUp).Offset(1, 0) 
NextRow.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
:=False, Transpose:=False 

今、私は、ダイナミックレンジを参照して、ループのようなものを持っていると思いますが、VBAは本当にお茶の私のカップではないと私はそれが仕事を得ることができません..だから、AA3、AA4などを参照する代わりに、私はAA3、AA4 .... AAxのデータを含む名前の範囲をreferebnceしたいと思います。 AA3 .... AA150の配列式の結果であるため、名前付き範囲に空白のセルも含まれる場合があります。

ありがとうございました！ /フレドリック

Answer 1

次の例では、各...次のループについて使用 によって指定範囲内の各セルをループ。 の範囲のセルの値がLimitの値を超えると、セルの色が黄色に変わります。

vba 
Sub ApplyColor() 
    Const Limit As Integer = 25 
    For Each c In Range("MyRange") 
     If c.Value > Limit Then 
      c.Interior.ColorIndex = 27 
     End If 
    Next c 
End Sub 

Source

ですから、このような何かを始めるかもしれません：

Calculate 

Dim NextRow As Range 

' get a range object from the named range 
For Each c In Range("[File.xls]Sheet1!NamedRange") 

    ' Copy the data 
    Worksheets(c.Value).Range("A1:A1500").Copy 

    ' Paste the data on the next empty row in sheet "Artiklar" 
    Sheets("Artiklar").Activate 
    Set NextRow = Range("A65536").End(xlUp).Offset(1, 0) 
    NextRow.PasteSpecial xlPasteValues 

Next c 

あなたは、私が名前付き範囲が参照されている方法でもう少し明示的だったことに気づくでしょうここでの要件は、範囲をどのように宣言したか（その範囲はどういうものか）によって変わるかもしれませんが、私がやったやり方はあなたのために働くでしょう。名前付き範囲の有効範囲の詳細については、リンク先の記事を参照してください。

Answer 2

次のコードが役に立ちます。私は名前付き範囲（私はそれをcopysheetsと呼ばれる）がアクティブなワークブック（スコープのワークブック）にあると仮定しました。

Sub copySheets() 

Dim sheetName As Range 
Dim copyRange As Range 
Dim destinationRange As Range 

For Each sheetName In Range("copysheets") 

    If sheetName.Value <> "" And sheetName.Value <> 0 Then 

    Set copyRange = Sheets(sheetName.Value).Range("A1:A1500")  
    Set destinationRange = Sheets("Artiklar").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 

    copyRange.Copy 
    destinationRange.PasteSpecial xlPasteValues 

    End If 

Next 

End Sub 

Answer 3

Dim myNamedRng as Range, cell as Range 
'... 
Set myNamedRng = Worksheets("MySheet").Range("myRange") '<-- set a variable referencing your named Range 
With Sheets("Artiklar") 
    For Each cell In myNamedRng 
     If cell.Value <>"" Then .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1500).Value = Worksheets(cell.Value).Range("A1:A1500").Value 
    Next cell 
End With 

Answer 4

- =問題は解決= -

私の質問へのご協力ありがとうございました！私が受け取ったすべての答えは、私のコードを改良するのに役立ちました。私のコードは正しく機能しています！

よろしく、 フレドリック