☰

Запрос формулы Excel — как автоматически копировать данные на определенные листы

tag-icon • tag-icon microsoft-excel worksheet-function microsoft-excel-2010 microsoft-excel-2013 spreadsheet
Запрос формулы Excel — как автоматически копировать данные на определенные листы

Вопрос по Microsoft Excel:

Как автоматически скопировать определенные данные с основного/главного листа на другие указанные листы?

EG - Главный лист регистрирует все данные. Я бы хотел, чтобы каждая строка данных копировалась на соответствующий лист. Данные либо попадают на лист красный/синий/зеленый в зависимости от того, что введено в ячейки для столбца 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

Связанный контент