Скопируйте строку вставки на несколько листов, если ячейка не подходит - PullRequest
Новая
       40

Скопируйте строку вставки на несколько листов, если ячейка не подходит

0 голосов
/ 17 января 2020

Вот проблема: данные на одном листе, и мне нужно их классифицировать. Я пытаюсь go сделать это следующим образом:

Я хотел сначала использовать этот код для копирования и вставки в соответствующий лист, но единственное, что он делает, это вставляет все в TargetK и TargetL. 

Sub Button6_Click()


Dim c As Range
Dim j As Long
Dim Source As Worksheet
Dim TargetA As Worksheet
Dim TargetB As Worksheet
Dim TargetC As Worksheet
Dim TargetD As Worksheet
Dim TargetE As Worksheet
Dim TargetF As Worksheet
Dim TargetG As Worksheet
Dim TargetH As Worksheet
Dim TargetI As Worksheet
Dim TargetJ As Worksheet
Dim TargetK As Worksheet
Dim TargetL As Worksheet
Dim i As Long

Set Source = ActiveWorkbook.Worksheets("Data") 'Where it is copying from
Set TargetA = ActiveWorkbook.Worksheets("Table1Dyn") 'Where it is copying to
Set TargetB = ActiveWorkbook.Worksheets("Table2Dyn")
Set TargetC = ActiveWorkbook.Worksheets("Table1Elec")
Set TargetD = ActiveWorkbook.Worksheets("Table2Elec")
Set TargetE = ActiveWorkbook.Worksheets("Table1Hab")
Set TargetF = ActiveWorkbook.Worksheets("Table2Hab")
Set TargetG = ActiveWorkbook.Worksheets("Table1HVAC")
Set TargetH = ActiveWorkbook.Worksheets("Table2HVAC")
Set TargetI = ActiveWorkbook.Worksheets("Table1ITS")
Set TargetJ = ActiveWorkbook.Worksheets("Table2ITS")
Set TargetK = ActiveWorkbook.Worksheets("Table1MISC")
Set TargetL = ActiveWorkbook.Worksheets("Table2MISC")


j = 3
For Each c In Source.Range("K3:K3000")
    If c = "03 - Dynamique" Then
       Source.Rows(c.Row).Copy TargetA.Rows(j)
       Source.Rows(c.Row).Copy TargetB.Rows(j)
       j = j + 1
       Else

         If c = "*04 - Electrique*" Then
         Source.Rows(c.Row).Copy TargetC.Rows(j)
         Source.Rows(c.Row).Copy TargetD.Rows(j)
         j = j + 1
         Else

             If c = "*06 - Habillage*" Then
             Source.Rows(c.Row).Copy TargetE.Rows(j)
             Source.Rows(c.Row).Copy TargetF.Rows(j)
             j = j + 1
             Else

                 If c = "*07 - HVAC*" Then
                 Source.Rows(c.Row).Copy TargetG.Rows(j)
                 Source.Rows(c.Row).Copy TargetH.Rows(j)
                 j = j + 1
                 Else

                    If c = "*08 - ITS*" Then
                     Source.Rows(c.Row).Copy TargetI.Rows(j)
                     Source.Rows(c.Row).Copy TargetJ.Rows(j)
                     j = j + 1
                     Else

             Source.Rows(c.Row).Copy TargetK.Rows(j)
             Source.Rows(c.Row).Copy TargetL.Rows(j)
             j = j + 1

                     End If
                 End If
             End If
        End If
    End If

Next c

End Sub

После этого я хотел go на каждом листе и удалить строки и столбцы, которые там не принадлежат. Должен быть более эффективный способ сделать это, но я не могу понять это.

1 Ответ

0 голосов
/ 17 января 2020

Как-то так должно работать. 

Sub Button6_Click()

    Dim v, ws, e, wb As Workbook, cNext As Range, j As Long, c As Range

    Set wb = ActiveWorkbook

    j = 3
    For Each c In wb.Worksheets("Data").Range("K3:K3000")

        v = c.Value
        ws = Empty

        'where are we copying to ?
        Select Case True
            Case v Like "*03 - Dynamique*": ws = Array("Table1Dyn", "Table2Dyn")
            Case v Like "*04 - Electrique*": ws = Array("Table1Elec", "Table2Elec")
            'add your other cases here
        End Select

        'found a match?
        If Not IsEmpty(ws) Then
            'copy to destination sheet(s)
            For Each e In ws
                c.EntireRow.Copy wb.Worksheets(e).Cells(j, j)

                'or do you want each sheet to fill row by row?
                'Set cNext = wb.Worksheets(e).Cells(Rows.Count, "K").End(xlUp).Offset(1, 0)
                'c.EntireRow.Copy cNext.EntireRow.Cells(1)
            Next e
            j = j + 1
        End If
    Next c

End Sub
...