將excel工作表中的數據拆分爲基於列值的多個工作簿

我使用此代碼（來自Splitting worksheet into multiple workbooks），並且代碼在第3列中使用簡短數據庫進行過濾時運行良好。但是，我有一個數據庫其中要用作過濾器的列，也稱爲字段，位於35列或「AI」中，並且在這種情況下代碼不起作用。所以，這段代碼只是根據已過濾列的值（好）創建工作簿，但數據本身未被過濾，從而創建（在本例中）三個相同的文件。有什麼建議麼？這是我使用的代碼：將excel工作表中的數據拆分爲基於列值的多個工作簿

Sub CreateBatchWorkbooks() 

On Error Resume Next 
Application.DisplayAlerts = False 

With ThisWorkbook.Sheets("CalcData") 'Replace the sheet name with the raw data sheet name 

Set Newsheet = ThisWorkbook.Sheets("cal") 

    If Newsheet Is Nothing Then 
      Worksheets.Add.Name = "cal" 
     Else 
      ThisWorkbook.Sheets("cal").Delete 
      Worksheets.Add.Name = "cal" 
    End If 

     FilterField = WorksheetFunction.Match("BatchNumber()", ThisWorkbook.Sheets("CalcData").Range("1:1"), 0) 

     .Columns(FilterField).Copy 

      With ThisWorkbook.Sheets("cal") 
       .Range("a1").PasteSpecial (xlPasteAll) 
       .Columns("a").RemoveDuplicates Columns:=1, Header:=xlYes 
      End With 

        For Each cell In ThisWorkbook.Sheets("cal").Columns("a").Cells 
         i = i + 1 
          If i <> 1 And cell.Value <> "" Then 
           .AutoFilterMode = False 
           .Rows(1).AutoFilter field:=FilterField, Criteria1:=cell.Value 
           Set new_book = Workbooks.Add 
           .UsedRange.Copy 
           new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll) 
           new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx" 
           new_book.Sheets(1).UsedRange.Columns.AutoFit 
           new_book.Save 
           new_book.Close 
          End If 
        Next cell 

         ThisWorkbook.Sheets("cal").Delete 
End With 

End Sub

在此先感謝！

來源

2016-08-03 dmalvareg

擺脫'On Error Resume Next'（參見[Documentation]（https://stackoverflow.com/documentation/） VBA/3211 /錯誤處理/ 11022 /恢復關鍵字））。由於這一行，您在代碼中遇到的任何錯誤都被完全忽略。回報任何錯誤消息（編輯您的帖子以包含它們）。然後閱讀有關錯誤處理的文檔部分的其餘部分。沒有任何理由可以使用OERN。 – FreeMan

此外，您正嘗試在一列範圍上過濾字段＃35。您鏈接到的上一篇文章在評論中顯示了此更正。 –

我剛更新了代碼。仍然沒有任何東西正在解決有什麼建議麼？ – dmalvareg

我找到了答案。我在這裏發佈它以防萬一有人使用命名錶或數據庫:)

Sub CreateBatchWorkbooks() 

On Error Resume Next 
Application.DisplayAlerts = False 

With ThisWorkbook.Sheets("CalcData") 'Replace the sheet name with the raw data sheet name 

Set Newsheet = ThisWorkbook.Sheets("cal") 

    If Newsheet Is Nothing Then 
      Worksheets.Add.Name = "cal" 
     Else 
      ThisWorkbook.Sheets("cal").Delete 
      Worksheets.Add.Name = "cal" 
    End If 

     FilterField = WorksheetFunction.Match("BatchNumber()", ThisWorkbook.Sheets("CalcData").Range("1:1"), 0) 

     .Columns(FilterField).Copy 

      With ThisWorkbook.Sheets("cal") 
       .Range("a1").PasteSpecial (xlPasteAll) 
       .Columns("a").RemoveDuplicates Columns:=1, Header:=xlYes 
      End With 

        Dim rngFilteredCalcData 
        For Each cell In ThisWorkbook.Sheets("cal").Columns("a").Cells 
         i = i + 1 
          If i <> 1 And cell.Value <> "" Then 
           Set rngFilteredCalcData = .ListObjects("tblCalcData").Range 
           rngFilteredCalcData.AutoFilterMode = False 
           rngFilteredCalcData.AutoFilter field:=FilterField, Criteria1:=cell.Value 

           Set new_book = Workbooks.Add 
           rngFilteredCalcData.SpecialCells(xlCellTypeVisible).Rows.Copy 
           new_book.Sheets(1).Range("a1").PasteSpecial (xlPasteAll) 
           new_book.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value & ".xlsx" 
           new_book.Sheets(1).UsedRange.Columns.AutoFit 
           new_book.Save 
           new_book.Close 
          End If 
        Next cell 

         ThisWorkbook.Sheets("cal").Delete 
End With 

End Sub

來源

2016-08-04 13:47:04 dmalvareg

將excel工作表中的數據拆分爲基於列值的多個工作簿

回答

相關問題