Sub TEST1()
'別シートに転記
Worksheets("Sheet1").Range("A1:C1").Copy Worksheets("Sheet2").Range("A1")
End Sub
「Sheet1」に次のように値を入力しました。
「Sheet1」の値
すでに、「Sheet2」はあることとしています。
では、VBAコードを実行してみます。
「Sheet2」に値を転記
「Sheet2」に値を、転記できました。
シートを追加して転記(Worksheets.Add)
次は、シートを追加して、追加したシートに値を転記してみます。
シートの追加は、「Worksheets.Add」を使うとできます。
シートを追加して、追加したシートに値を転記するVBAコードです。
Sub TEST2()
'別シートを追加
Worksheets.Add after:=ActiveSheet
'別シートに転記
Worksheets("Sheet1").Range("A1:C1").Copy ActiveSheet.Range("A1")
End Sub
手順は、
シートを追加
値を転記
という流れです。
「Sheet1」に値を入力しました。
「Sheet1」の値
では、VBAコードを実行します。
まず、シートを追加すると、「Sheet2」が作成されます。
「Sheet2」が追加される
追加したシートに、「Sheet1」の値が転記されます。
追加したシートに値を転記
追加したシートに、値が転記されました。
こんな感じで、シートを追加して、値を転記する場合は、「Worksheets.Add」を使います。
条件を指定して別シートに転記
次は、条件を指定して別シートに転記してみます。
次の表を用意しました。
使う表
この表で、支店が「東京」の値だけを、別シートに転記してみます。
VBAコードは、こんな感じになります。
Sub TEST3()
'支店を東京でフィルタ
Worksheets("Sheet1").Range("A1").AutoFilter 2, "東京"
'シートを追加
Worksheets.Add after:=ActiveSheet
ActiveSheet.Name = "東京" 'シート名を変更'フィルタしたデータを、別シートに転記
Worksheets("Sheet1").Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
'フィルタを解除
Worksheets("Sheet1").Range("A1").AutoFilter
End Sub
手順は、
①オートフィルタで、「東京」でフィルタする
②シートを追加する
③フィルタした表を、追加したシートに貼り付け
④フィルタを解除する
という流れです。
では、VBAコードを実行します。
「東京」でフィルタ
まず、支店が「東京」でフィルタされます。
シートを追加
次に、シートが追加されます。
追加したシートに転記
最後に、フィルタしたデータが、追加したシートに貼り付けられます。
条件を指定して、別シートにデータを転記できました。
こんな感じで、条件を指定する場合は、オートフィルタを使うと便利です。
条件別で複数の別シートに転記
次は、条件別で、複数の別シートに転記する、というのをやってみます。
先ほどと同じ表を使います。
使う表
支店は、「東京」、「大阪」、「名古屋」、「福岡」の4つがあります。
この表の支店ごとに、別シートに転記します。
VBAコードは、こんな感じになります。
Sub TEST4()
'配列を作成
Dim A
A = Array("東京", "大阪", "名古屋", "福岡")
For i = 0 To 3
'支店でフィルタ
Worksheets("Sheet1").Range("A1").AutoFilter 2, A(i)
'シートを追加
Worksheets.Add after:=ActiveSheet
ActiveSheet.Name = A(i) 'シート名を変更'フィルタしたデータを、別シートに転記
Worksheets("Sheet1").Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
'フィルタを解除
Worksheets("Sheet1").Range("A1").AutoFilter
Next
End Sub
Sub TEST5()
Dim A
'「支店」で重複しないリストにフィルタする
Set A = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns(2)
A.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
'重複しないリストを別セルにコピー
A.Copy Worksheets("Sheet1").Range("E1")
Worksheets("Sheet1").ShowAllData 'フィルタ解除'重複しないリストを、配列に格納
Dim Data
With Worksheets("Sheet1")
Data = .Range(.Range("E2"), .Range("E2").End(xlDown))
End With
'重複しないリストをクリア
Worksheets("Sheet1").Range("E1").CurrentRegion.Clear
'重複しないリスト分ループ
For i = 1 To UBound(Data, 1)
'支店を、フィルタする
Worksheets("Sheet1").Range("A1").AutoFilter 2, Data(i, 1)
'別シートを追加
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Data(i, 1) '名前を変更'フィルタしデータを、追加したシートに転記
Worksheets("Sheet1").Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
'フィルタ解除
Worksheets("Sheet1").Range("A1").AutoFilter
Next
End Sub
Sub TEST6()
'別ブックを開く
Workbooks.Open Filename:=ThisWorkbook.Path & "\別ブック.xlsx"
Dim A, B
'別ブックに転記
Set A = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Set B = Workbooks("別ブック.xlsx").Worksheets("Sheet1").Range("A1")
A.Copy B
'別ブックを保存して、閉じる
Workbooks("別ブック.xlsx").Save
Workbooks("別ブック.xlsx").Close
End Sub
手順は、
①別ブックを開く
②別ブックに値を転記
③別ブックを保存して閉じる
という流れです。
次のブックを用意しました。
転記元のブック
フォルダ構成
同じフォルダ内に、「別ブック.xlsx」という空のブックを保存しています。
では、VBAコードを実行します。
手順①:別ブックを開く
まず、「別ブック.xlsx」が開かれます。
手順②:別ブックに値を転記
次に、値が転記されます。
「別ブック.xlsx」という別ブックに値を転記されます。
手順③:別ブックを保存して閉じる
最後に別ブックを保存して、閉じます。
では、結果をみてみます。
【結果】別ブックに値を転記
結果として、「別ブック.xlsx」に値を転記することができます。
「別ブック.xlsx」を開いてみます。
こんな感じで、すでにある別ブックに値を転記する場合は、別ブックを開いて転記します。
新規ブックに転記(Workbooks.Add)
次は、新規ブックに値を転記するというのをやってみます。
新規ブックを作成するには、「Workbooks.Add」を使います。
新規ブックに値を転記するVBAコードです。
Sub TEST7()
'別ブックを追加
Workbooks.Add
Dim A, B
'新規ブックに、転記
Set A = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Set B = ActiveWorkbook.Worksheets("Sheet1").Range("A1")
A.Copy B
'新規ブックを保存して、閉じる
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\別ブック.xlsx"
ActiveWorkbook.Close
End Sub
Sub TEST8()
'「大阪」でフィルタ
Worksheets("Sheet1").Range("A1").AutoFilter 2, "大阪"
'新規ブックを追加
Workbooks.Add
Dim A, B
'新規ブックに、転記
Set A = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Set B = ActiveWorkbook.Worksheets("Sheet1").Range("A1")
A.Copy B
'新規ブックを、保存して閉じる
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\大阪.xlsx"
ActiveWorkbook.Close
'元ブックのフィルタを解除
Worksheets("Sheet1").Range("A1").AutoFilter
End Sub
Sub TEST9()
Dim A
A = Array("東京", "大阪", "名古屋", "福岡")
For i = 0 To 3
'支店でフィルタ
Worksheets("Sheet1").Range("A1").AutoFilter 2, A(i)
'新規ブックを追加
Workbooks.Add
Dim B, C
'新規ブックに、転記
Set B = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Set C = ActiveWorkbook.Worksheets("Sheet1").Range("A1")
B.Copy C
'新規ブックを、保存して閉じる
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & A(i) & ".xlsx"
ActiveWorkbook.Close
'元ブックのフィルタを解除
Worksheets("Sheet1").Range("A1").AutoFilter
Next
End Sub
手順は、
①「支店」のリストを作成
②それぞれの「支店」でフィルタする
③別ブックを追加して、転記する
④名前を付けて保存して、閉じる
⑤それぞれの「支店」で②~④を繰り返す
という流れです。
では、実行してみます。
手順①:「支店」のリストを作成
「支店」のリストを作成して、変数に入力します。
手順②:それぞれの「支店」でフィルタする
次に、重複しないリストの1番目のデータである、「東京」でフィルタされます。
手順③:別ブックを追加して、転記する
新規ブックが追加されます。
フィルタしたデータが、この新規ブックに転記されます。
手順④:名前を付けて保存して、閉じる
新規ブックを名前を付けて保存して、閉じます
手順⑤:それぞれの「支店」で②~④を繰り返す
これらの手順が、それぞれの「支店」で繰り返されます。
それぞれのブックは、次のように値が入力されています。
【結果】各ブックのデータ
こんな感じで、条件別で、別ブックに転記することができます。
重複しないリストを作成して条件別で複数ブックに転記
次は、「重複しないリスト」を作成して、条件別で、複数ブックに転記する、というのをやってみます。
次の表から、「支店」で「重複しないリスト」を作成して、別ブックに転記してみます。
用意した表
こちらの表で、それぞれ「東京」、「大阪」、「名古屋」、「福岡」だけの値を別ブックに転記します。
VBAコードは、こちらです。
Sub TEST10()
Dim A
'「支店」で重複しないリストをフィルタ
Set A = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns(2)
A.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
'重複しないリストを別セルに入力
A.Copy Worksheets("Sheet1").Range("E1")
'フィルタを解除
Worksheets("Sheet1").ShowAllData
'重複しないリストを、配列に格納
Dim Data
With Worksheets("Sheet1")
Data = .Range(.Range("E2"), .Range("E2").End(xlDown))
End With
'重複しないリストを削除
Worksheets("Sheet1").Range("E1").CurrentRegion.Clear
'重複しないリストの支店の値で、ループ
For i = 1 To UBound(Data, 1)
'重複しないリストの値で、フィルタ
Worksheets("Sheet1").Range("A1").AutoFilter 2, Data(i, 1)
'新規ブックを追加
Workbooks.Add
Dim B, C
'新規ブックに、フィルタしたデータを転記
Set B = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Set C = ActiveWorkbook.Worksheets("Sheet1").Range("A1")
B.Copy C
'新規ブックを保存して、閉じる
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Data(i, 1) & ".xlsx"
ActiveWorkbook.Close
'オートフィルタを解除
Worksheets("Sheet1").Range("A1").AutoFilter
Next
End Sub