条件式で1枚のシートから別のシートにデータをコピーするマクロ

Question

私は巨大なデータがあるプロジェクトに取り組んでいます。各データには行と列の番号があります。私はこのデータを条件ごとにそれぞれのシートに移動したい。

Excelワークブック：

まずシート名は、それが賢明な状態であり、それぞれのシートに移動する必要があり、すべてのデータを持っている、Shortage Reportです。

例：

Shortage Report列Aは都市名を持っている：

Mumbai 
Bangalore 
Hyderabad 
Kochi 
Chennai 
..... so on. 

とColumn Dは場所の短い名前を持っています。すなわち、条件式を用い

Mumbai - MU 
Bangalore - BU 
etc. 

欲しいへ移動データ：

• カラムA = Mumbaiおよび列D = MU次いでシートMUに移動する場合。
• カラムA = BangaloreおよびカラムD = BUの場合は、BUに移動します。
• カラムA = ChennaiおよびカラムD = CHの場合は、CHに移動します。

これらのデータをそれぞれのシートに移動するためのVBスクリプトを作成してください。

私にとって大きな助けになるでしょう。私はこの作業を完了するのにほぼ3時間を費やしています。

Answer 1

次のようないくつかのデータがある場合：Shortage Reportという名前のシートで

A   B C 
1 Mumbai  MU Some1 
2 Bangalore BU Some2 
3 Hyderabad HY Some3 
4 Kochi  KO Some4 
5 Chennai  CH Some5 
6 Mumbai  MU Some6 
7 Bangalore BU Some7 
8 Chennai  CH Some8 
9 Hyderabad HY Some9 
10 Mumbai  MU Some10 
11 Mumbai  MU Some11 
12 Chennai  CH Some12 
13 Mumbai  MU Some13 
14 Bangalore BU Some14 
15 Hyderabad HY Some15 
16 Bangalore BU Some16 
17 Chennai  CH Some17 
18 Bangalore BU Some18 
19 Kochi  KO Some19 
20 Kochi  KO Some20 
21 Bangalore BU Some21 

を。などBU

という名前のシートでMU

A   B C 
1 Bangalore BU Some2 
2 Bangalore BU Some7 
3 Bangalore BU Some14 
4 Bangalore BU Some16 
5 Bangalore BU Some18 
6 Bangalore BU Some21 

という名前のシートで

A  B C 
1 Mumbai MU Some1 
2 Mumbai MU Some6 
3 Mumbai MU Some10 
4 Mumbai MU Some11 
5 Mumbai MU Some13 

：のようなデータを持つ5枚を作るために

Sub qwerty() 
    Dim i, Lastrow, j 
    Dim SheetName As String 
    Dim wb As Workbook 

    Set sr = Worksheets("Shortage Report") 
    Lastrow = sr.Range("B" & Rows.Count).End(xlUp).Row 

    If wb Is Nothing Then Set wb = ThisWorkbook 

    For j = 1 To Lastrow 

     SheetName = sr.Range("B" & j).Value 

     Application.DisplayAlerts = False 
     On Error Resume Next 

     If wb.Sheets(SheetName) Is Nothing Then 
      With ThisWorkbook 
       .Sheets.Add(After:=.Sheets(.Sheets.Count)).name = SheetName 
      End With 
     End If 
     Application.DisplayAlerts = True 

     sr.Range("A" & j & ":C" & j).Copy 
     i = wb.Sheets(SheetName).Range("A" & Rows.Count).End(xlUp).Row + 1 
     wb.Sheets(SheetName).Range("A" & i & ":C" & i).PasteSpecial Paste:=xlValues 

    Next j 

End Sub 

：次に、あなたはこのコードを使用することができます