问VBA Excel -宏范围语法问题
EN

Stack Overflow用户

提问于 2020-04-08 21:10:47

回答 1查看 53关注 0票数 0

所以我一直在努力让这个电子表格正常工作。基本上，我是按Techs名称(H列)对数据进行预排序的。然后，我想将分配给他们的每个设备复制到带有其名称的单独工作表中。我似乎找不出复制行的范围语法。我有两个计数器在运行。Counter用于比较每行，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

excel

vba

syntax

copy

range

回答 1

Stack Overflow用户

发布于 2020-04-09 00:56:17

避免选择和使用变量。

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