谁对它感兴趣，您可以在下面查看我的解决方案。我的数据文件运行大约 20 分钟。得出这个结果需要时间。通过重新复制复制的宏并记录/调整它们。
Sub delete_0()
'change directory
Workbooks.Open Filename:= _
"G:\01_Phone_Bills\extbills\v_201212\Vodafone_Dec_12.csv"
'delete all rows which contains 0 in column 15 in the original invoice
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 15).End(xlUp).Row To 1 Step -1
If Cells(i, 15) = "0" Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
'startthe next macros
Application.Run "'make it readable.xlsm'!delete_member_PhoneNumbers"
Application.Run "'make it readable.xlsm'!delete_Tx_Easy_Roaming"
Application.Run "'make it readable.xlsm'!Make_it_readable"
Application.Run "'make it readable.xlsm'!renamesheet"
Application.Run "'make it readable.xlsm'!delete_non_user_phone_numbers"
ChDir "G:\01_Phone_Bills\extbills\v_201212"
ActiveWorkbook.SaveAs Filename:= _
"G:\01_Phone_Bills\extbills\v_201212\Vodafone_Dec_12.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.Run "'make it readable.xlsm'!Autosum_insert"
Application.Run "'make it readable.xlsm'!copy_amount"
Application.Run "'make it readable.xlsm'!delete_Bill_summery_0"
Application.Run "'make it readable.xlsm'!MakeMultipleXLSfromWB"
End Sub
Sub delete_member_PhoneNumbers()
'delete all rows which contains phone number ... in column 10
'in the original invoice, user have not to pay for that calls
Dim a As Long
Application.ScreenUpdating = False
For a = Cells(Rows.Count, 10).End(xlUp).Row To 1 Step -1
If Cells(a, 10) = "123456789" Then Rows(a).Delete
Next a
Application.ScreenUpdating = True
End Sub
Sub delete_Tx_Easy_Roaming()
'delete all rows which contains Tx Easy Roaming in column 11
'in the original invoice, user have not to pay for that fee
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 11).End(xlUp).Row To 1 Step -1
If Cells(i, 11) = "Tx Easy Roaming" Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
End Sub
Sub Make_it_readable()
'
' Convert the original invoice into a readable excel format
' Replace all file names
'
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
Columns("I:I").Select
Selection.NumberFormat = "#,##0.00"
Columns("J:L").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
ActiveCell.FormulaR1C1 = "PhoneNu"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Date"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Time"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Country Code"
Range("E1").Select
ActiveCell.FormulaR1C1 = "City Code"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Destination"
Columns("F:F").Select
Selection.NumberFormat = "0"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Duration"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Cost"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Total amount"
Cells.Select
Cells.EntireColumn.AutoFit
Cells.Select
ActiveWorkbook.Worksheets("Vodafone_Dec_12").Sort.SortFields.Clear 'replace "Voda..."
ActiveWorkbook.Worksheets("Vodafone_Dec_12").Sort.SortFields.Add Key:=Range( _
"A2:A50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Vodafone_Dec_12").Sort 'replace "Voda..."
.SetRange Range("A1:R50000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").Select
Selection.NumberFormat = "## #######"
ActiveSheet.Name = "Bill Summery"
'create the number of sheets which you need
Dim lnumber As String
Dim i As Long
Anf:
lnumber = InputBox("How often should the macro run ?", , 3)
'check the input for a figure
If IsNumeric(lAnzahl) Then
For i = 1 To CLng(lnumber)
Range("A:A:J:J").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
Next i
Else
MsgBox "Please enter a figure !", vbInformation
GoTo Anf
End If
End Sub
Sub renamesheet()
'
' renames each sheet
'
'
Sheets("Sheet1").Name = "Tel 123456789"
Sheets("Sheet2").Name = "Tel 234567890"
Sheets("Sheet3").Name = "Tel 345678901"
Public Sub delete_non_user_phone_numbers()
'delte all pfone numbers without that from the user
'Sheet activation
Sheets("Tel 123456789").Select
'find last row
lz = Cells(Rows.Count, 1).End(xlUp).Rows.Row
'check all rows
For t = lz To 2 Step -1 'count back to row 2
'check if ther is "..."in the first column
If Not Cells(t, 1).Value = "123456789" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
'Sheet activation
Sheets("Tel 234567890").Select
lz = Cells(Rows.Count, 1).End(xlUp).Rows.Row
For t = lz To 2 Step -1
If Not Cells(t, 1).Value = "234567890" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
'Sheet activation
Sheets("Tel 345678901").Select
lz = Cells(Rows.Count, 1).End(xlUp).Rows.Row
For t = lz To 2 Step -1
If Not Cells(t, 1).Value = "345678901" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
Sub Autosum_insert()
'do the autosum in each sheet column I and fill it in J2
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Bill Summery").Select
Columns("A:J").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets(Array("Bill Summery", "Tel 123456789", "Tel 234567890", "Tel 345678901")).Select
Sheets("Bill Summery").Activate
Dim intI As Integer
For intI = 2 To ThisWorkbook.Worksheets.Count
Range("J2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-1]:R[1111]C[-1])"
Next intI
End Sub
Sub copy_amount()
'
' copy_amount Macro
'
'copy A1 and J2 from every sheet in Bill Summery
'
Sheets("Tel 123456789").Select
Range("J2,A2").Select
Selection.Copy
Sheets("Bill Summery").Select
Range("A1:B1").Select
ActiveSheet.Paste
Sheets("Tel 234567890").Select
Range("J2,A2").Select
Selection.Copy
Sheets("Bill Summery").Select
Range("A2:B2").Select
ActiveSheet.Paste
Sheets("Tel 345678901").Select
Range("J2,A2").Select
Selection.Copy
Sheets("Bill Summery").Select
Range("A3:B3").Select
ActiveSheet.Paste
End Sub
Sub delete_Bill_summery_0()
'delete all rows in sheet Bill summery which have a 0 printed in column2
Sheets("Bill Summery").Select
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) = "0" Then Rows(i).Delete
Next i
End Sub
Option Explicit
Sub MakeMultipleXLSfromWB()
'Split worksheets in current workbook into
' many separate workbooks D.McRitchie, 2004-06-12
'Close each module AND the VBE before running to save time
' provides a means of seeing how big sheets really are
'Hyperlinks and formulas pointing to other worksheets within
' the original workbook will usually be unuseable in the new workbooks.
Dim CurWkbook As Workbook
Dim wkSheet As Worksheet
Dim newWkbook As Workbook
Dim wkSheetName As String
Dim shtcnt(3) As Long
Dim xpathname As String, dtimestamp As String
dtimestamp = Format(Now, "yyyymmdd_hhmmss")
'change the directory
xpathname = "G:\01_Phone_Bills\extbills\v_201212\D" & dtimestamp & "\"
MkDir xpathname
Set CurWkbook = Application.ActiveWorkbook
shtcnt(2) = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each wkSheet In CurWkbook.Worksheets
shtcnt(1) = shtcnt(1) + 1
Application.StatusBar = shtcnt(1) & "/" & shtcnt(2) & _
" " & wkSheet.Name
wkSheetName = Trim(wkSheet.Name)
If wkSheetName = Left(Application.ActiveWorkbook.Name, _
Len(Application.ActiveWorkbook.Name) - 4) Then _
wkSheetName = wkSheetName & "_D" & dtimestamp
Workbooks.Add
ActiveWorkbook.SaveAs _
Filename:=xpathname & wkSheetName & ".xls", _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False
Set newWkbook = ActiveWorkbook
Application.DisplayAlerts = False
newWkbook.Worksheets("sheet1").Delete
On Error Resume Next
newWkbook.Worksheets(wkSheet.Name).Delete
On Error GoTo 0
Application.DisplayAlerts = True
CurWkbook.Worksheets(wkSheet.Name).Copy Before:=newWkbook.Sheets(1)
'no duplicate sheet1 because they begin with "a"
ActiveWorkbook.Save
ActiveWorkbook.Close
Next wkSheet
Application.StatusBar = False 'return control to Excel
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub