VBA - 분할 Excel 워크 시트 나 Excel에서 다음 시트를

Question

여러 개의 파일로 :

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 

나는 시간 [S] 열 (또는 ND.T 열)에 의해 파일에이 시트를 분리하려는

그래서 내가 가진이 별도의 파일

파일 : 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 

파일 : 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 

파일 : 나는 첫 번째 열에 고유 한 이름으로 파일을 분리 다음 VBA 코드를 발견 지금까지

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 

을 13.39.xlxs, 그래서 난 그냥이의 변형이 될 필요가 생각 :

는

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

다음 줄 :

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

는해야

,

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

원본 파일에서 열 1의 항목은 문자열입니다. 새 파일에서는 정수입니다. 따라서 UniqueNames 컬렉션이 채워지지 않습니다. 위의 수정 프로그램은 UniqueNames에 추가하기 전에 열 1의 모든 항목을 문자열로 변환합니다.

는 파일 이름의 일부로 날짜를 사용하려고하기 때문에 그것은 실패 편집. 당신이 날짜 열을 정렬 할 때

OutName = OutName & Index 

와

OutName = OutName & UniqueNames(Index) 

를 교체하십시오. 당신은 모든 열을 복사 할 경우, 당신은 또한 난 당신의 코드가 달성하려는 것에 대해 조금 너무 복잡하다고 생각

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

Answer 2

와

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

를 교체해야

. 가정 난

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

이 매크로를 사용해보십시오 다음 워크 시트를 (. 내가 직장에서, 그래서이 매크로이이 확실히 내가 코드를 반복하고 있지 않다 그래서 통합 할 수있는 비트 자세한 내 if 문) :

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