选择每一行并放入不同的工作表

Question

在我的第 2 列中的工作功能中，我想选择该行并将其复制到同名的工作表中。在我运行代码的所有时间里，都会出现一条消息 1004 错误。

`Sub ventilation()

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim LastRow As Integer
Dim dernierelilgne As Integer

Application.ScreenUpdating = False

' faire une boucle pour effacer les feuilles seelctionner'

For j = 1 To 9
    
    Sheets(j).Select
    LastRow = Range("A1000000").End(xlUp).Row
    For i = LastRow To 6 Step -1
        Sheets(j).Select
        Selection.Delete Shift:=xlUp
    Next i
    
    Sheets("source").Select
    derniereligne = Range("A1000000").End(xlUp).Row
      
      'en fonction du mot dans la colonne, envoyer vers la feuille correspondante'
    
    For k = 6 To derniereligne
    
        Sheets("source").Select
        If Sheets(j).Name = Cells(k, 2).Value Then
        
            Rows(k).Select
            Selection.Copy
            Sheets(j).Select
            LastRow = Range("A1000000").End(xlUp).Row + 1
            Cells(LastRow, 1).Select
            ActiveSheet.Paste
            
        End If
        
    Next k
    
Next j

Sheets("Source").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

结束子

如果您有解决方案，请！

Answer 1

 Sub ventilation()

    Dim ws As Worksheet, wsSrc As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim sName As String
    Dim LastRow As Long, derniereligne As Long

    Application.ScreenUpdating = False

    ' faire une boucle pour effacer les feuilles seelctionner'
    Set wsSrc = ThisWorkbook.Sheets("source")
    derniereligne = wsSrc.Range("A" & Rows.Count).End(xlUp).Row

    For j = 1 To 9
        Set ws = ThisWorkbook.Sheets(j)
        sName = ws.Name
        LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
        ws.Rows("2:" & LastRow).Delete
        LastRow = 2
    Next j
      'en fonction du mot dans la colonne, envoyer vers la feuille correspondante'
    
        For k = 2 To derniereligne
            If wsSrc.Cells(k, 2).Value = sName Then
                wsSrc.Rows(k).Copy ws.Range("A" & LastRow)
                LastRow = LastRow + 1
            End If
        Next k
    
    Application.ScreenUpdating = True
End Sub

Answer 2

没有选择

更新 1 - LastRow 改为使用 UsedRange

更新 2 - 匹配 A 列

Sub ventilation()

    Dim ws As Worksheet, wsSrc As Worksheet, header As Range
    Dim i As Long, j As Long, k As Long
    Dim sName As String
    Dim LastRow As Long, derniereligne As Long

    Application.ScreenUpdating = False

    ' faire une boucle pour effacer les feuilles seelctionner'
    Set wsSrc = ThisWorkbook.Sheets("source")
    Set header = wsSrc.Range("A1:I1")
    derniereligne = wsSrc.Range("A" & Rows.Count).End(xlUp).Row

    For j = 1 To 9
        Set ws = ThisWorkbook.Sheets(j)
        sName = ws.Name
        
        LastRow = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
        If LastRow >= 3 Then ws.Rows("3:" & LastRow).Delete
        LastRow = 3

        'en fonction du mot dans la colonne, envoyer vers la feuille correspondante'
        header.Copy ws.Range("A2")
        For k = 2 To derniereligne
            If wsSrc.Cells(k, "A").Value = sName Then
                wsSrc.Rows(k).Copy ws.Range("A" & LastRow)
                LastRow = LastRow + 1
            End If
        Next k
    Next j
    Application.ScreenUpdating = True
    MsgBox derniereligne - 1 & " rows scanned on worksheet " & wsSrc.Name, vbInformation
End Sub