обновление именного листа клиента, если его имя в столбце A

Question

У меня есть основной лист, в котором столбец A содержит имя клиента, а столбцы с B по H - значения даты, бренда и т. Д. Я написал vba только для 2 листов, и он работает, но я хочу сделать этот скрипт коротким, поскольку у меня будет 30до 40 листов потом ... основная идея, если столбец имеет имя клиента.скопируйте эту строку с его именем, это может быть несколько строк (A4, A7, A10) .... а затем откройте его лист и вставьте туда.может ли кто-нибудь помочь мне в этом

    Sub customersheetpaste()

'Ashraf
    A = Worksheets("Main Sheet").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 4 To A
    If Worksheets("Main Sheet").Cells(i, 1).Value = "Ashraf" Then
    Worksheets("Main Sheet").Range("B" & i & ":H" & i).Copy
    Worksheets("Ashraf").Activate
    B = Worksheets("Ashraf").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Ashraf").Cells(B + 1, 1).Select
    ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
    Worksheets("Main Sheet").Activate
End If
'Mozam Shahid
    If Worksheets("Main Sheet").Cells(i, 1).Value = "Mozam Shahid" Then
    Worksheets("Main Sheet").Range("B" & i & ":H" & i).Copy
    Worksheets("Mozam Shahid").Activate
    B = Worksheets("Mozam Shahid").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Mozam Shahid").Cells(B + 1, 1).Select
    ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
    Worksheets("Main Sheet").Activate

End If
Next

    Application.CutCopyMode = False
    ThisWorkbook.Worksheets("Main Sheet").Cells(1, 1).Select
End Sub

Answer 1

@ user3099345 Я устал переставлять, с 3 заполненными ячейками от A4 до A: 6 это работает, но если я выбираю Range от A: 4 до A: 7 (3 заполненных и 4 пустых ячейки), выдает ошибку сценариядиапазона, поскольку следующая ячейка пуста.

Option Explicit

Public Sub customersheetpaste()

    Dim wsMain As Worksheet
    Dim wsName As Worksheet
    Dim lrowMain As Long
    Dim lrowName As Long
    Dim i As Long
    Dim j As Integer
    Dim arr As Variant

    Set wsMain = ThisWorkbook.Worksheets("Main Sheet")
    lrowMain = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
    arr = [transpose(A4:A7)]

    For i = 1 To UBound(arr)
        For j = 4 To lrowMain
            If wsMain.Cells(j, 1).Value = arr(i) Then
                wsMain.Range("B" & j & ":H" & j).Copy
                Set wsName = ThisWorkbook.Worksheets(arr(i))
                With wsName
                    .Activate
                    lrowName = .Cells(Rows.Count, 1).End(xlUp).Row
                    .Cells(lrowName + 1, 1).Select
                    .PasteSpecial xlPasteValuesAndNumberFormats

                End With
                wsMain.Activate
            End If
        Next
    Next

    Application.CutCopyMode = False

    wsMain.Cells(1, 1).Select

End Sub

Answer 2

Вы можете создать массив имен, которые вы хотите проверить, или вы можете загрузить имена в столбце A и прокрутить массив имен, чтобы сделать его быстрее.Попробуйте это:

Option Explicit

Public Sub customersheetpaste()

    Dim wsMain As Worksheet
    Dim wsName As Worksheet
    Dim lrowMain As Long
    Dim lrowName As Long
    Dim i As Long
    Dim j As Integer
    Dim arr(1 To 2) As String

    Set wsMain = ThisWorkbook.Worksheets("Main Sheet")
    lrowMain = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
    arr(1) = "Ashraf"
    arr(2) = "Mozam"

    For i = 1 To UBound(arr)
        For j = 4 To lrowMain
            If wsMain.Cells(j, 1).Value = arr(i) Then
                wsMain.Range("B" & j & ":H" & j).Copy
                Set wsName = ThisWorkbook.Worksheets(arr(i))
                With wsName
                    .Activate
                    lrowName = .Cells(Rows.Count, 1).End(xlUp).Row
                    .Cells(lrowName + 1, 1).Select
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                wsMain.Activate
            End If
        Next
    Next

    Application.CutCopyMode = False

    wsMain.Cells(1, 1).Select

End Sub