☰

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

相关内容