VBA Excel - 宏范围语法问题

Question

所以我一直在努力让这个电子表格正常运行。基本上我按技术名称（H 列）对我的数据进行了预排序。然后，我想将他们分配的每个设备复制到带有他们名字的单独工作表中。我似乎无法弄清楚复制行的范围语法。我有 2 个计数器在运行。计数器保持比较每一行，TechCount 移动我的复制范围的起点。我是一个完全的新手，所以我相信有一种更有效的方法可以做到这一点。

示例：Data Set

    'Create individual Worksheets for Techs with Primary & Secondary Assignments
Dim ws As Worksheet
Dim TechNm As String
Dim wsNM As String
Dim counter As Integer
Dim TechCount As Integer


    ActiveWorkbook.Worksheets("DATA SET").Select
    TechNm = ActiveWorkbook.Sheets("DATA SET").Range("H2").Value
    counter = 0
    TechCount = 0


Do

        If IsEmpty(Range("H2").Value) = True Then
                    Exit Do
        End If

        If TechNm = ActiveWorkbook.Sheets("DATA SET").Range("H2").Offset(counter + 1, 0).Value Then
            counter = counter + 1

        ElseIf TechNm <> ActiveWorkbook.Sheets("DATA SET").Range("H2").Offset(counter + 1, 0).Value Then

                 'Create Worksheet with Tech Name
                wsNM = ActiveWorkbook.Sheets("DATA SET").Range("H2")
                Set ws = ActiveWorkbook.Sheets.Add(after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
                ws.Name = wsNM

                 'Copy Header Row to new worksheet
                ActiveWorkbook.Sheets("DATA SET").Rows(1).EntireRow.Copy ActiveWorkbook.Sheets(wsNM).Range("A1")

                 'Move Tech assignments to new sheet 
                **ActiveWorkbook.Sheets("DATA SET").Range("A" & TechCount & ":A" & counter).EntireRow.Copy ActiveWorkbook.Sheets(wsNM).Range("A2")**
                    Cells.Select
                    With Selection
                        .HorizontalAlignment = xlLeft
                        .VerticalAlignment = xlBottom
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = False
                        .EntireColumn.AutoFit
                    End With

                    Rows(1).EntireColumn.AutoFilter
                    Range("A2").Select
                    Application.CutCopyMode = False

                'Change Do Loop Parameters
                ActiveWorkbook.Worksheets("DATA SET").Select
                counter = counter + 1
                TechCount = counter
                TechNm = ActiveWorkbook.Sheets("DATA SET").Range("H2").Offset(counter, 0).Value


        End If
Loop


ActiveWorkbook.Worksheets("TECH ASSIGNMENTS").Select

End Sub

Answer 1

避免选择和使用变量。

Sub test()
    'Create individual Worksheets for Techs with Primary & Secondary Assignments
Dim Ws As Worksheet, myWs As Worksheet
Dim TechNm As String
Dim wsNM As String
Dim counter As Integer
Dim TechCount As Integer
Dim Wb As Workbook

    'ActiveWorkbook.Worksheets("DATA SET").Select
    Set Wb = ActiveWorkbook
    Set myWs = Wb.Worksheets("DATA SET")
    'TechNm = ActiveWorkbook.Sheets("DATA SET").Range("H2").Value
    TechNm = myWs.Range("H2").Value
    counter = 0
    TechCount = 0


Do
    With myWs
        'If IsEmpty(Range("H2").Value) = True Then
        If IsEmpty(.Range("H2").Value) = True Then
                    Exit Do
        End If

        'If TechNm = ActiveWorkbook.Sheets("DATA SET").Range("H2").Offset(counter + 1, 0).Value Then
        If TechNm = .Range("H2").Offset(counter + 1, 0).Value Then
            counter = counter + 1

        'ElseIf TechNm <> ActiveWorkbook.Sheets("DATA SET").Range("H2").Offset(counter + 1, 0).Value Then
        ElseIf TechNm <> .Range("H2").Offset(counter + 1, 0).Value Then

                 'Create Worksheet with Tech Name
                wsNM = .Range("H2")
                Set Ws = Wb.Sheets.Add(after:=Wb.Sheets(Wb.Sheets.Count))
                Ws.Name = wsNM

                 'Copy Header Row to new worksheet
                'ActiveWorkbook.Sheets("DATA SET").Rows(1).EntireRow.Copy ActiveWorkbook.Sheets(wsNM).Range("A1")
                .Rows(1).EntireRow.Copy Ws.Range("A1")
                 'Move Tech assignments to new sheet
                **ActiveWorkbook.Sheets("DATA SET").Range("A" & TechCount & ":A" & counter).EntireRow.Copy ActiveWorkbook.Sheets(wsNM).Range("A2")**
                .Range("A" & TechCount & ":A" & counter).EntireRow.Copy Ws.Range("A2")
                With Ws.Cells
                    'Cells.Select
                    'With Selection
                        .HorizontalAlignment = xlLeft
                        .VerticalAlignment = xlBottom
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = False
                        .EntireColumn.AutoFit


                    .Rows(1).EntireColumn.AutoFilter
                    '.Range("A2").Select
                    Application.CutCopyMode = False
                End With
                'Change Do Loop Parameters
                'ActiveWorkbook.Worksheets("DATA SET").Select
                counter = counter + 1
                TechCount = counter
                TechNm = .Range("H2").Offset(counter, 0).Value
        End If
    End With
Loop


'ActiveWorkbook.Worksheets("TECH ASSIGNMENTS").Select
Wb.Worksheets("TECH ASSIGNMENTS").Activate
End Sub