vba - Split Excel-Arbeitsblatt in mehrere Dateien

Question

ich das folgende Blatt in Excel haben:

ID ND.T Time [s] Position X [%s] Position Y [%s] Speed [%s] Area [%s] Width [%s] MeanIntensity 
1 1  3.87   417.57   11.46   0.06  339.48  14.1   245.65 
1 2  8.72   417.37   11.68   0.04  342.61  14.15   239.34 
1 3  13.39  417.57   11.66   0.04  344.17  14.3   239.48 
2 1  3.87   439.01   6.59   0.02  342.61  11.66   204.47 
2 2  8.72   438.97   6.65   0.007  342.61  10.7   197.96 
2 3  13.39  438.94   6.66   0.03  345.74  11.03   214.74 

Ich mag würde dieses Blatt in Dateien, die von der Zeit [s] Spalte (oder ND.T Spalte) trennen, so ich habe diese separaten Dateien

Datei: 3.87.xlxs

ID ND.T Time [s] Position X [%s] Position Y [%s] Speed [%s] Area [%s] Width [%s] MeanIntensity 
    1 1  3.87   417.57   11.46   0.06  339.48  14.1   245.65 
    2 1  3.87   439.01   6.59   0.02  342.61  11.66   204.47 

Datei: 8.72.xlxs

ID ND.T Time [s] Position X [%s] Position Y [%s] Speed [%s] Area [%s] Width [%s] MeanIntensity 
1 2  8.72   417.37   11.68   0.04  342.61  14.15   239.34 
2 2  8.72   438.97   6.65   0.007  342.61  10.7   197.96 

Datei: 13.39.xlxs

ID ND.T Time [s] Position X [%s] Position Y [%s] Speed [%s] Area [%s] Width [%s] MeanIntensity 
1 3  13.39  417.57   11.66   0.04  344.17  14.3   239.48 
2 3  13.39  438.94   6.66   0.03  345.74  11.03   214.74 

Bisher habe ich den folgenden VBA-Code gefunden haben, die Dateien durch einen eindeutigen Namen in der ersten Spalte trennt, so dass ich denke, es müsste nur eine Variante davon sein

Option Explicit 
Sub SplitIntoSeperateFiles() 

Dim OutBook As Workbook 
Dim DataSheet As Worksheet, OutSheet As Worksheet 
Dim FilterRange As Range 
Dim UniqueNames As New Collection 
Dim LastRow As Long, LastCol As Long, _ 
    NameCol As Long, Index As Long 
Dim OutName As String 

'set references and variables up-front for ease-of-use 
Set DataSheet = ThisWorkbook.Worksheets("Sheet1") 
NameCol = 1 
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol)) 

'loop through the name column and store unique names in a collection 
For Index = 2 To LastRow 
    On Error Resume Next 
     UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol) 
    On Error GoTo 0 
Next Index 

'iterate through the unique names collection, writing 
'to new workbooks and saving as the group name .xls 
Application.DisplayAlerts = False 
For Index = 1 To UniqueNames.Count 
    Set OutBook = Workbooks.Add 
    Set OutSheet = OutBook.Sheets(1) 
    With FilterRange 
     .AutoFilter Field:=NameCol, Criteria1:=UniqueNames(Index) 
     .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1") 
    End With 
    OutName = ThisWorkbook.FullName 
    OutName = Left(OutName, InStrRev(OutName, "\")) 
    OutName = OutName & UniqueNames(Index) 
    OutBook.SaveAs Filename:=OutName, fileFormat:=xlExcel8 
    OutBook.Close SaveChanges:=False 
    Call ClearAllFilters(DataSheet) 
Next Index 
Application.DisplayAlerts = True 

End Sub 

'safely clear all the filters on data sheet 
Sub ClearAllFilters(TargetSheet As Worksheet) 
    With TargetSheet 
     TargetSheet.AutoFilterMode = False 
     If .FilterMode Then 
      .ShowAllData 
     End If 
    End With 
End Sub 

Answer 1

Die folgende Zeile:

UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol) 

sollte

UniqueNames.Add Item:=CStr(DataSheet.Cells(Index, NameCol).Value), Key:=CStr(DataSheet.Cells(Index, NameCol).Value) 

In der ursprünglichen Datei sind die Elemente in Spalte eins Zeichenfolgen. In der neuen Datei sind sie Ganzzahlen. Daher wird die UniqueNames-Auflistung nicht gefüllt. Der obige Fix konvertiert alle Elemente in Spalte eins in Zeichenfolgen, bevor Sie versuchen, sie UniqueNames hinzuzufügen.

bearbeiten

Es versagt, weil es das Datum als Teil des Dateinamens zu verwenden versucht. Versuchen

OutName = OutName & UniqueNames(Index) 

mit

OutName = OutName & Index 

ersetzt, wenn Sie auf der Datumsspalte sind zu sortieren.

Wenn Sie alle Spalten kopieren möchten, können Sie auch

Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol)) 

mit

Set FilterRange = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol)) 

Answer 2

denken ersetzen sollte ich den Code für ein wenig zu kompliziert ist, was Sie erreichen wollen . Unter der Annahme, ich habe das folgende Arbeitsblatt

ID ID2 
1 1 
1 2 
1 3 
1 4 
2 3 
2 4 
2 5 
2 6 

diesen Makro Versuchen (ich bei der Arbeit bin, so dass dieser Makro ein bisschen ausführlicher ist dies auf jeden Fall so konsolidiert wird, kann ich mich nicht zu wiederholen Code in meiner if-Anweisungen.):

Sub asdf() 
    Dim a As Worksheet 
    Dim b As Worksheet 

    Set a = Sheets("Sheet1") 

    currentId = "" 

    For x = 2 To a.Range("a65536").End(xlUp).Row 'get to the last row 
     If currentId = "" Then 
      currentId = x 
      If a.Range("a" & currentId).Value <> a.Range("a" & x + 1).Value Then 
       a.Range(Range("a" & x), a.Range("b" & currentId)).Select 
       a.Range(Range("a" & x), Range("b" & currentId)).Copy 
       Workbooks.Add 
       Set b = ActiveSheet 
       b.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial 
       ActiveWorkbook.SaveAs Filename:="C:\ENTER PATH HERE\" & a.Range("a" & x).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
       ActiveWorkbook.Close 
       currentId = "" 
      End If 
     ElseIf Range("a" & currentId).Value <> a.Range("a" & x + 1).Value Then 
      a.Range(Range("a" & x), a.Range("b" & currentId)).Select 
      a.Range(Range("a" & x), Range("b" & currentId)).Copy 
      Workbooks.Add 
      Set b = ActiveSheet 
      b.Range("a65536").End(xlUp).Offset(1, 0).PasteSpecial 
      ActiveWorkbook.SaveAs Filename:="C:\ENTER PATH HERE\" & a.Range("a" & x).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
      ActiveWorkbook.Close 
      currentId = "" 
     Else 
      ' 
     End If 
    Next x 

End Sub