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

所以这并不是一个正确的答案，但经过一个周末的研究后，我潜入了一些python并且能够比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)

一个工作表到多个工作表

2 个答案: