根據列值複製工作表

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處理。您在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是不可靠的。