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

这适用于主工作表，但必须复制多个选项卡，这只能捕获一个工作表。如何扩展它以便将其他工作表复制到该文件中？

例如： ColumnA ID1 ID2 ID3

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

Answer 1

这是一个允许您搜索工作表并按名称转到它的函数。

 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

Answer 2

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

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是不可靠的。

根据列值复制工作表

2 个答案: