Question

我在工作簿中有一个包含数据5000行的3张（Data，Data1，Data2）的大型数据集。 ColumnA包含多个3个字母代码。（共有160个不同的3个字母代码-ABC）

我希望在我的C：\中保存工作簿的副本，然后转到工作表“数据”，过滤掉前三个字母代码-ABC，选择剩余的数据并删除它并保存为'ABC' 。对其他工作表“Data1”和“Data2”

执行相同操作

然后我想做下一个或循环160个不同代码的其余部分 - （ABB，ACB，BEC，HGN等）

因此，结果将是160个名为ABC，ABB的工作簿，仅包含其各自的数据。

我已经为ABC做了一个代码，但我不能让它返回并使用过滤后的数据重新创建场景。

 Sub Tcode()


 Dim tcode As String
 Dim Tcode As String
 Dim ColNumber As Integer  
 Dim FPath As String
 Dim r As Range




'Do While ColNumber < 162
'Save a copy of the Datasheet
        'ActiveWorkbook.SaveAs Filename:="P:\Work\New\R1H.xlsm", FileFormat:= _
      ' xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

      FPath = "P:\Work\New\"

          With Sheets("tcode")
                 For Each r In .Range("a2", .Range("a" & Rows.Count).End(xlUp))
         If r.Value <> "" Then
    Application.DisplayAlerts = False

      End If

 'Go to Data Sheet and filter out the tcode and delete the rest
 Sheets("Data").Select
 Rows("1:1").Select
  Selection.AutoFilter Field:=1, Criteria1:=Sheets("tcode").Range("A2").Value
 ActiveSheet.Range("$A$1:$W$15521").AutoFilter Field:=1, Criteria1:=Array( _
 "R1H", "RA2", "RA3", "RA4", "RA7", "RA9", "RAE", "RAJ", "RAL", "RAN", "RAP", "RAS", "RAX", _
  "RBA", "RBB", "RBD", "RBK", "RBL", "RBN", "RBQ", "RBS", "RBT", "RBV", "RBZ", "RC1", "RC3", _
   "RC9", "RCB", "RCD", "RCF", "RCU", "RCX", "RD1", "RD3", "RD7", "RD8", "RDD", "RDE", "RDU", _
   "RDZ", "RE9", "REF", "REM", "REN", "REP", "RET", "RF4", "RFF", "RFR", "RFS", "RFW", "RGM", _
   "RGN", "RGP", "RGQ", "RGR", "RGT", "RH8", "RHM", "RHQ", "RHU", "RHW", "RJ1", "RJ2", "RJ6", _
   "RJ7", "RJC", "RJD", "RJE", "RJF", "RJL", "RJN", "RJR", "RJZ", "RK5", "RK9", "RKB", "RKE", _
   "RL1", "RL4", "RLN", "RLQ", "RLT", "RLU", "RM1", "RM2", "RM3", "RMC", "RMP", "RN3", "RN5", _
   "RN7", "RNA", "RNL", "RNQ", "RNS", "RNZ", "RP4", "RP5", "RP6", "RPA", "RPC", "RPY", "RQ3", _
   "RQ6", "RQ8", "RQM", "RQQ", "RQW", "RQX", "RR1", "RR7", "RR8", "RRF", "RRJ", "RRK", "RRV", _
   "RT3", "RTD", "RTE", "RTF", "RTG", "RTH", "RTK", "RTP", "RTR", "RTX", "RV8", "RVJ", "RVL", _
   "RVR", "RVV", "RVW", "RVY", "RW3", "RW6", "RWA", "RWD", "RWE", "RWF", "RWG", "RWH", "RWJ", _
   "RWP", "RWW", "RWY", "RX1", "RXC", "RXF", "RXH", "RXK", "RXL", "RXN", "RXP", "RXQ", "RXR", _
   "RXW", "RYJ", "RYR"), Operator:=xlFilterValues
 Range("A99").Select
 Range(Selection, Selection.End(xlDown)).Select
 Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
 Selection.Delete Shift:=xlUp
 Selection.AutoFilter
 ActiveWorkbook.Save
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False

 'Range("A99:W15520").Select
 'Selection.End(xlUp).Select
 'Range("A99").Select


 'Goto Appendix sheet and filter out the tcode and delete the rest
 Sheets("Appendix").Select
  Rows("1:1").Select
 Selection.AutoFilter
 ActiveSheet.Range("$A$1:$W$20481").AutoFilter Field:=1, Criteria1:=Array( _
 "R1H", "RA2", "RA3", "RA4", "RA7", "RA9", "RAE", "RAJ", "RAL", "RAN", "RAP", "RAS", "RAX", _
 "RBA", "RBB", "RBD", "RBK", "RBL", "RBN", "RBQ", "RBS", "RBT", "RBV", "RBZ", "RC1", "RC3", _
 "RC9", "RCB", "RCD", "RCF", "RCU", "RCX", "RD1", "RD3", "RD7", "RD8", "RDD", "RDE", "RDU", _
 "RDZ", "RE9", "REF", "REM", "REN", "REP", "RET", "RF4", "RFF", "RFR", "RFS", "RFW", "RGM", _
 "RGN", "RGP", "RGQ", "RGR", "RGT", "RH8", "RHM", "RHQ", "RHU", "RHW", "RJ1", "RJ2", "RJ6", _
 "RJ7", "RJC", "RJD", "RJE", "RJF", "RJL", "RJN", "RJR", "RJZ", "RK5", "RK9", "RKB", "RKE", _
 "RL1", "RL4", "RLN", "RLQ", "RLT", "RLU", "RM1", "RM2", "RM3", "RMC", "RMP", "RN3", "RN5", _
 "RN7", "RNA", "RNL", "RNQ", "RNS", "RNZ", "RP4", "RP5", "RP6", "RPA", "RPC", "RPY", "RQ3", _
 "RQ6", "RQ8", "RQM", "RQQ", "RQW", "RQX", "RR1", "RR7", "RR8", "RRF", "RRJ", "RRK", "RRV", _
 "RT3", "RTD", "RTE", "RTF", "RTG", "RTH", "RTK", "RTP", "RTR", "RTX", "RV8", "RVJ", "RVL", _
 "RVR", "RVV", "RVW", "RVY", "RW3", "RW6", "RWA", "RWD", "RWE", "RWF", "RWG", "RWH", "RWJ", _
  "RWP", "RWW", "RWY", "RX1", "RXC", "RXF", "RXH", "RXK", "RXL", "RXN", "RXP", "RXQ", "RXR", _
 "RXW", "RYJ", "RYR"), Operator:=xlFilterValues

 Range("A126").Select
 Range(Selection, Selection.End(xlDown)).Select
 Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
 Selection.Delete Shift:=xlUp
  Selection.AutoFilter
 ActiveWorkbook.Save
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False
'Selection.End(xlUp).Select
'Range("A126").Select




  'Goto Appendix sheet and filter out the tcode and delete the rest
  Sheets("Appendix 2").Select
  Rows("1:1").Select
  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$J$5441").AutoFilter Field:=1, Criteria1:=Array( _
  "R1H", "RA2", "RA3", "RA4", "RA7", "RA9", "RAE", "RAJ", "RAL", "RAN", "RAP", "RAS", "RAX", _
    "RBA", "RBB", "RBD", "RBK", "RBL", "RBN", "RBQ", "RBS", "RBT", "RBV", "RBZ", "RC1", "RC3", _
  "RC9", "RCB", "RCD", "RCF", "RCU", "RCX", "RD1", "RD3", "RD7", "RD8", "RDD", "RDE", "RDU", _
  "RDZ", "RE9", "REF", "REM", "REN", "REP", "RET", "RF4", "RFF", "RFR", "RFS", "RFW", "RGM", _
  "RGN", "RGP", "RGQ", "RGR", "RGT", "RH8", "RHM", "RHQ", "RHU", "RHW", "RJ1", "RJ2", "RJ6", _
  "RJ7", "RJC", "RJD", "RJE", "RJF", "RJL", "RJN", "RJR", "RJZ", "RK5", "RK9", "RKB", "RKE", _
  "RL1", "RL4", "RLN", "RLQ", "RLT", "RLU", "RM1", "RM2", "RM3", "RMC", "RMP", "RN3", "RN5", _
  "RN7", "RNA", "RNL", "RNQ", "RNS", "RNZ", "RP4", "RP5", "RP6", "RPA", "RPC", "RPY", "RQ3", _
 "RQ6", "RQ8", "RQM", "RQQ", "RQW", "RQX", "RR1", "RR7", "RR8", "RRF", "RRJ", "RRK", "RRV", _
 "RT3", "RTD", "RTE", "RTF", "RTG", "RTH", "RTK", "RTP", "RTR", "RTX", "RV8", "RVJ", "RVL", _
 "RVR", "RVV", "RVW", "RVY", "RW3", "RW6", "RWA", "RWD", "RWE", "RWF", "RWG", "RWH", "RWJ", _
 "RWP", "RWW", "RWY", "RX1", "RXC", "RXF", "RXH", "RXK", "RXL", "RXN", "RXP", "RXQ", "RXR", _
 "RXW", "RYJ", "RYR"), Operator:=xlFilterValues
 Range("A36").Select
 Range(Selection, Selection.End(xlDown)).Select
 Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
 Selection.Delete Shift:=xlUp
 Selection.AutoFilter
 ActiveWorkbook.Save
 Application.DisplayAlerts = False
   Application.ScreenUpdating = False

      ActiveWorkbook.SaveAs FPath & r.Value & ".XLS"
    Next r
  End With

 End Sub

如果有人能指出我正确的方向，那就太好了。提前致谢

Answer 1

这样就可以了。它将所有工作表复制到一个文件中（无论有多少）。它复制每个工作表的第一行（假设列名称在那里）。但是，当然，在第一行之后，它将仅复制以该表的三字母代码开头的行。它使用适当的三字母代码作为名称保存每张工作表。

在代码中更改需要保存工作表的目录！

如果要保存所有工作表，请在保存后删除newworkbook.close行。（160张，我想你不想;但是））

如果表格中有公式，可能都无法正常工作，您必须进行测试;代码可能需要进行一些修改。

明智的是，你会慢下来，

Sub DoIt()
    Dim ThreeletterCodes As New Collection
    Dim i As Long
    Dim Cnt As Long
    Dim Code
    Dim Worksheet As Worksheet, NewWorksheet As Worksheet
    Dim NewWorkbook As Workbook
    Dim Row As Long, NewRow As Long

    Dim DestPath As String

    DestPath = "E:\TEMP\" ' use \ at end of path

    With ThisWorkbook.Worksheets(1)
        Cnt = .UsedRange.Rows.Count
        For i = 1 To Cnt
            If Len(.Cells(i, 1).Value) = 3 Then
                On Error Resume Next
                ThreeletterCodes.Add .Cells(i, 1).Value, .Cells(i, 1).Value
                On Error GoTo 0
            End If
        Next
    End With
    ' All unique three letter codes now in the collection
    ' Speed up execution considerably by not calculating and no screenupdates
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    ' Iterate through all the codes
    For Each Code In ThreeletterCodes
        ' Make a new file for each code
        Set NewWorkbook = Application.Workbooks.Add
        ' Iterate through all the sheets in a file
        For Each Worksheet In ThisWorkbook.Worksheets
            ' Make a new worksheet in the new file; or select an existing one if there is one already
            If Worksheet.Index > NewWorkbook.Worksheets.Count Then
                Set NewWorksheet = NewWorkbook.Worksheets.Add(After:=NewWorkbook.Worksheets(NewWorkbook.Worksheets.Count))  ' Add sheet after last worksheet
            Else
                Set NewWorksheet = NewWorkbook.Worksheets(Worksheet.Index)
            End If
            ' make the sheets have the same name as in the original file
            NewWorksheet.Name = Worksheet.Name
            ' Always copy first row with Column names
            Worksheet.Rows(1).Copy Destination:=NewWorksheet.Rows(1)
            ' And copy all the rest if first cell has the three letters
            Cnt = Worksheet.UsedRange.Rows.Count
            NewRow = 2
            For Row = 2 To Cnt
                ' Status message
                Application.StatusBar = "Copying Code " & Code & " Sheet " & Worksheet.Name & " Line " & Row: DoEvents
                ' If first cell of row has the three letter code
                If Worksheet.Cells(Row, 1).Value = Code Then
                    ' then copy it to a new row on the destination sheet (in the new file)
                    Worksheet.Rows(Row).Copy Destination:=NewWorksheet.Rows(NewRow)
                    NewRow = NewRow + 1
                End If
            Next
        Next
        ' Save and close the new file
        NewWorkbook.SaveAs DestPath & Code
        NewWorkbook.Close
    Next
    ' Restore speed-up options.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

保存工作簿的副本，过滤数据并删除过滤的数据和循环

1 个答案: