Question

i有一个主表，其中A列保存了客户名称，B列到H列是值，日期，品牌等我只为2张纸写了一个VBA及其工作，但我想使该脚本简短，因为之后我将有30到40张纸... 主要思想是A列中是否有客户名称。复制具有他的名字的那一行，可以是多行（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

您可以创建要检查的名称数组，也可以将名称加载到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

Answer 2

@ user3099345我厌倦了转置，用3个填充的单元格从A4到A：6可以工作，但是如果我选择从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

如果客户的名称在A列中，则更新客户的命名表

2 个答案: