Один рабочий лист на несколько листов

Question

В настоящее время у меня есть один лист, в котором есть 8 столбцов. одним из названий столбцов является дата. Мне нужен макрос, который берет все данные и разбивается каждый день в свою собственную книгу. Это возможно? Я нашел код ниже, но код не заставил его работать.

Option Explicit 

Sub ParseItems() 
'Jerry Beaucaire (4/22/2010) 
'Based on selected column, data is filtered to individual workbooks 
'workbooks are named for the value plus today's date 
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long 
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String 

'Sheet with data in it 
Set ws = Sheets("Original Data") 

'Path to save files into, remember the final \ 
SvPath = "C:\2010\" 

'Range where titles are across top of data, as string, data MUST 
'have titles in this row, edit to suit your titles locale 
vTitles = "A1:Z1" 

'Choose column to evaluate from, column A = 1, B = 2, etc. 
vCol = Application.InputBox("What column to split data by? " & vbLf _ 
    & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1) 
If vCol = 0 Then Exit Sub 

'Spot bottom row of data 
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row 

'Speed up macro execution 
Application.ScreenUpdating = False 

'Get a temporary list of unique values from key column 
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy,  CopyToRange:=ws.Range("EE1"), Unique:=True 

'Sort the temporary list 
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _ 
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 

'Put list into an array for looping (values cannot be the result of formulas, must be constants) 
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants)) 

'clear temporary worksheet list 
ws.Range("EE:EE").Clear 

'Turn on the autofilter, one column only is all that is needed 
ws.Range(vTitles).AutoFilter 

'Loop through list one value at a time 
For Itm = 1 To UBound(MyArr) 
    ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) 

    ws.Range("A1:A" & LR).EntireRow.Copy 
    Workbooks.Add 
    Range("A1").PasteSpecial xlPasteAll 
    Cells.Columns.AutoFit 
    MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1 

    ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal 
    'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51 'use for Excel 2007+ 
    ActiveWorkbook.Close False 

    ws.Range(vTitles).AutoFilter Field:=vCol 
Next Itm 

'Cleanup 
ws.AutoFilterMode = False 
MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!" 
Application.ScreenUpdating = True 
End Sub 

Answer 1

Попробуйте это - там обязательно будет меньше/чистый код, но он работал на меня:

Option Explicit 
Sub test() 

Dim Sh1 As Worksheet, tmp As Worksheet, Sh2 As Worksheet 
Dim LastRow As Long, LastCol As Long, usedRows As Long 
Dim j As Integer, i As Integer 
Dim HdrRow As Range, Rng As Range, DateCol As Range, cel As Range, xl As Range 
Dim ShtArr() 
'Define boundaries of worksheet, find "Date" column: 
Set Sh1 = ActiveWorkbook.Sheets("Sheet1") 
    With Sh1 
     LastRow = .Range("a" & .Rows.Count).End(xlUp).Row 
     LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 

     Set HdrRow = .Range(.Cells(1, 1), .Cells(1, LastCol)) 

     With HdrRow 
      Set Rng = .Find(What:="Date") 
      If Rng Is Nothing Then 
       MsgBox "Date Column not found" 
       Exit Sub 
      Else 
       Set DateCol = .Cells(Rng.Column).EntireColumn 
      End If 
     End With 
    End With 
'Create array of dates: 
Set tmp = Sheets.Add 
    With tmp 
     DateCol.Copy .Range("a1") 
     .Range("a:a").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("b1"), Unique:=True 
     .Columns(1).Delete 
     .Columns(2).Cells.NumberFormat = "@" 
     usedRows = .Range("a" & tmp.Rows.Count).End(xlUp).Row 
     For Each cel In .Range(Cells(2, 1), Cells(usedRows, 1)) 
      cel.Offset(0, 1).Value = Format(cel, "Medium Date") 
     Next cel 
     ShtArr = .Range(Cells(2, 1), Cells(usedRows, 2)) 
    End With 
'Add sheet for each date, and copy from original sheet: 
For j = LBound(ShtArr, 1) To UBound(ShtArr, 1) 
    Set Sh2 = Sheets.Add 
     With Sh2 
      HdrRow.Copy .Range("a1") 
      .Name = (ShtArr(j, 2)) 
      i = 2 
      For Each xl In Sh1.Range(Sh1.Cells(1, Rng.Column), Sh1.Cells(LastRow, Rng.Column)) 
       If xl.Value = ShtArr(j, 1) Then 
        xl.EntireRow.Copy .Range("a" & i) 
        i = i + 1 
       End If 
      Next xl 
     End With 
    Set Sh2 = Nothing 
Next j 
'Delete temporary sheet: 
Application.DisplayAlerts = False 
    tmp.Delete 
Application.DisplayAlerts = True 

End Sub 

Answer 2

Так что это не совсем правильный ответ, но после выходных исследований I нырнул в какой-то питон и смог сделать это быстрее, чем vba. Думал, что поделился бы тем, кого это интересует.

import csv 
import pandas as pf 
import glob, os 


os.chdir('/Users/Chris/PycharmProjects/firstfile/') 
for file in glob.glob("*python.csv"): 
    print(file) 

r = pf.read_csv(file) 
r.head() 

#prints out how many rows were searched 
print r.describe() 
tradeDates = r['Trade Date'].unique() 

r.name = 'Trade Date' 

#for loop to run through the trade dates and make new .csv files 
for trades in tradeDates: 
    outfilename = trades 
    printName = outfilename + ".csv" 

    #prints out the file name..not necessary just gives me piece of mind 
    print printName 

    #makes new .csv files 
    r[r['Trade Date'] == trades].to_csv(printName)