根据列值复制工作表

Question

我是 Excel vba 的新手，但我已经使用 access vba 有一段时间了。

我有一些代码可以根据 excel 中的不同列将主文件拆分为其他几个文件

Sub SplitbyValue()
   Dim FromR As Range, ToR As Range, All As Range, Header As Range
   Dim Wb As Workbook
   Dim Ws As Worksheet
  'Get the header in this sheet
   Set Header = Range("D8").EntireRow

  'Visit each used cell in column D, except the header
   Set FromR = Range("D9")
   For Each ToR In Range(FromR, Range("D" & Rows.Count).End(xlUp).Offset(1))
     'Did the value change?
     If FromR <> ToR Then
       'Yes, get the cells between
       Set All = Range(FromR, ToR.Offset(-1)).EntireRow
       'Make a new file



       Set Wb = Workbooks.Add(xlWBATWorksheet)
        'Copy the data into there


       With Wb.ActiveSheet
         Header.Copy .Range("A8")
         All.Copy .Range("A9")
       End With
       'Save it


       Wb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
         " - " & FromR.Value & ".xls", xlWorkbookNormal
       Wb.Close
       'Remember the start of this section
       Set FromR = ToR
     End If
   Next
 End Sub

这对主工作表很有用，但必须复制多个选项卡，而且这只捕获一张工作表。如何扩展它以便将其他工作表也复制到该文件中？

示例： A栏 编号1 ID2 ID3

这会创建三个文件 (Id1)(Id2)(Id3) 但忽略其他工作表。

Answer 1

创建一个包含循环并使用With...End With statement 定义正在处理的工作表。您在Worksheets collection 上使用Worksheet object 循环通过For Each...Next Statement，但我通常使用每个工作表的索引。

Sub SplitbyValue()
    Dim FromR As Range, ToR As Range, dta As Range, hdr As Range
    Dim w As Long, ws As Worksheet, wb As Workbook, nuwb As Workbook

    'Get the header in this sheet

    Set wb = ActiveWorkbook

    For w = 1 To wb.Worksheets.Count
        With wb.Worksheets(w)
            Set hdr = .Range(.Cells(8, "D"), .Cells(8, Columns.Count).End(xlToLeft))

            'Visit each used cell in column D, except the header
            Set FromR = .Range("D9")
            For Each ToR In .Range(FromR, .Range("D" & Rows.Count).End(xlUp).Offset(1))
                'Did the value change?
                If FromR <> ToR Then
                    'Yes, get the cells between
                    Set dta = .Range(FromR, ToR.Offset(-1)).EntireRow

                    'Make a new file
                    Set nuwb = Workbooks.Add(xlWBATWorksheet)

                    'Copy the data into there
                    With nuwb.Sheet1
                         hdr.Copy .Range("A8")
                         dta.Copy .Range("A9")
                    End With

                    'Save it
                    nuwb.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy.mm.dd") & _
                        " - " & FromR.Value & ".xls", xlWorkbookNormal
                    nuwb.Close False
                    Set nuwb = Nothing

                    'Remember the start of this section
                    Set FromR = ToR
                End If
            Next ToR

        End With
    Next w
End Sub

我没有设置完整的测试环境，但这应该会让您朝着正确的方向前进。我一直觉得依赖 ActiveSheet 是不可靠的。

Answer 2

这是一个功能，可让您搜索工作表并按名称转到它。

 Private Sub loopsheets(strSheetName As String)
    iFoundWorksheet = 0
    For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
        Set ws = ea.Worksheets(iIndex)
        If UCase(ws.Name) = UCase(strSheetName) Then
            iFoundWorksheet = iIndex
            Exit For
        End If
    Next iIndex
    If iFoundWorksheet = 0 Then
        MsgBox "No worksheet was found with the name RESULTS (this is not case sensetive). Aborting."
    End If
    Set ws = ea.Worksheets(iFoundWorksheet)
    ws.Activate

End Sub

如果你只想循环它们，你只需要 for 循环。

    Dim iIndex as Integer
    For iIndex = 1 To ea.ActiveWorkbook.Worksheets.Count
        Set ws = ea.Worksheets(iIndex)
        ws.Activate

        'Call your code here.
        SplitbyValue

    Next iIndex