根据列值复制工作表-Copyworksheetsbasedoncolumnvalue

0  

Here is a function that will allow you to search for a sheet and goto it by name.

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

 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

If you want to just loop them all you just need the for loop.

如果你想只循环它们,你只需要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

0  

Create an encompassing loop and define the worksheet being processed with a With...End With statement. You loop through a For Each...Next Statement using a Worksheet object on the Worksheets collection but I typically use the index of each worksheet.

创建一个包含循环并使用With ... End With语句定义正在处理的工作表。使用Worksheets集合上的Worksheet对象循环遍历For Each ... Next语句,但我通常使用每个工作表的索引。

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

I did not set up a full test environment but this should get you heading in the right direction. I've always found it unreliable to depend on ActiveSheet.

我没有建立一个完整的测试环境,但这应该让你朝着正确的方向前进。我一直觉得依赖ActiveSheet是不可靠的。