☰

Excel 数式クエリ - 特定のシートにデータを自動的にコピーする方法

tag-icon • tag-icon microsoft-excel worksheet-function microsoft-excel-2010 microsoft-excel-2013 spreadsheet
Excel 数式クエリ - 特定のシートにデータを自動的にコピーする方法

Microsoft Excel に関する質問:

メイン/マスター シートから特定のデータを他の指定シートに自動的にコピーするにはどうすればよいですか?

例えば、マスター シートにはすべてのデータが記録されます。各データ行を対応するシートにコピーしたいとします。データは、列 D のセルに入力された内容に応じて、赤/青/緑のシートに送られます。

編集: 私が言いたいことをよりわかりやすく説明するために、以下に画像を添付しました。

ここに画像の説明を入力してください

答え1

次のマクロは、メイン シートをグループに分割します。列数と行数は重要ではありません。マクロはシート名とコード名間のマッピングに依存するため、最後の列のみが重要です。指定されたコード値を持つシートが存在しない場合、レコードはメイン シートにそのまま残ります。必須として、コード名は最後の列になければなりません。

Option Explicit
'Assumptions:
'The Code is in the last column
Sub DataSplitter()
Application.ScreenUpdating = False
On Error Resume Next
Dim noOfRows As Long
Dim noOfColumns As Long
Dim noOfRowsInCodeSheet As Variant
Dim i As Long 'counter
Dim j As Long 'counter
Dim sE As Boolean 'sheet exists flag
Dim sheetEmpy As Boolean
Dim code As String
Dim c As New Collection 'store noOfRowsInCodeSheet
Dim cRows As New Collection 'rows to delete

j = 1
'check how many columns
Do While Len(Cells(1, j).Value) > 0
j = j + 1
Loop
noOfColumns = j - 1

'check how many rows
i = 1
Do While Len(Cells(i, 1).Value) > 0
    i = i + 1
Loop
noOfRows = i - 1

'loop through the data
For i = 2 To noOfRows
    code = Cells(i, noOfColumns).Value
    'check if sheet exists
    If Sheets(code) Is Nothing Then
        sE = False ' sheet with code name does not exist
    Else
        sE = True ' sheet with code name exists
    End If
    'if sheet exists then check the noOfRows based on code
    If sE = True Then
        noOfRowsInCodeSheet = c.Item(code)
        If noOfRowsInCodeSheet Is Empty Then
            'the sheet was not visited during this execution
            'check no of rows in code sheet
            j = 1
            Do While Len(Sheets(code).Cells(j, 1).Value) > 0
                j = j + 1
            Loop
            noOfRowsInCodeSheet = j - 1
            If noOfRowsInCodeSheet = 0 Then
                'add headers
                For j = 0 To noOfColumns
                    Sheets(code).Cells(1, j).Value = Cells(1, j).Value
                Next j
                noOfRowsInCodeSheet = noOfRowsInCodeSheet + 1
            End If
            If noOfRowsInCodeSheet >= 1 Then
                noOfRowsInCodeSheet = noOfRowsInCodeSheet + 1
                'populate rows
                For j = 1 To noOfColumns
                    'Sheets(code).Cells(noOfRowsInCodeSheet, j).Value = Cells(i, j).Value 'it works but looses formatting
                    Cells(i, j).Copy
                    Sheets(code).Cells(noOfRowsInCodeSheet, j).PasteSpecial Paste:=xlPasteFormats
                    Sheets(code).Cells(noOfRowsInCodeSheet, j).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                Next j
                c.Remove code
                c.Add Item:=noOfRowsInCodeSheet, Key:=code
                cRows.Add Item:=i, Key:=CStr(i)
            End If
        End If
    Else
        'if sheet does not exist then do nothing (it's possible to _
        'automatically add it if required)
    End If
Next i

‘Uncomment to MOVE (cut-paste) rows (3 below lines)
‘Comment to COPY (copy-paste) rows (3 below lines)
For j = cRows.Count To 1 Step -1
    Rows(cRows.Item(j)).EntireRow.Delete
Next j

Application.ScreenUpdating = True
End Sub

関連情報