Скопируйте рабочие листы на основе значения столбца

Question

Я довольно недавно знаком с Excel vba, но уже некоторое время пользуюсь 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.