Excel Formula Query - วิธีการคัดลอกข้อมูลไปยังแผ่นงานเฉพาะโดยอัตโนมัติ

คำถาม Microsoft Excel:

ฉันจะคัดลอกข้อมูลบางอย่างจากแผ่นหลัก / แผ่นต้นแบบไปยังแผ่นงานอื่นที่ระบุได้อย่างไร

EG - มาสเตอร์ชีตจะบันทึกข้อมูลทั้งหมด ฉันต้องการคัดลอกข้อมูลแต่ละแถวไปยังแผ่นงานที่เกี่ยวข้อง ข้อมูลจะไปที่แผ่นแดง / น้ำเงิน / เขียวขึ้นอยู่กับสิ่งที่ป้อนในเซลล์สำหรับคอลัมน์ D

แก้ไข: รูปภาพที่แนบมาด้านล่างเพื่อลองและอธิบายสิ่งที่ฉันพูดได้ดีกว่า

แมโครต่อไปนี้แบ่งแผ่นงานหลักออกเป็นกลุ่ม จำนวนคอลัมน์และแถวไม่มีนัยสำคัญ เฉพาะคอลัมน์สุดท้ายเท่านั้นที่มีความสำคัญเนื่องจากแมโครอาศัยการแมประหว่างชื่อชีตและชื่อรหัส หากแผ่นงานที่มีค่ารหัสที่กำหนดไม่มีอยู่บันทึกจะยังคงอยู่ในแผ่นงานหลัก ตามที่ต้องมีชื่อรหัสจะต้องอยู่ในคอลัมน์สุดท้าย

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