複製指定行和列到包含autosum函數的新worrkbook

Question

首先，我必須說，我絕對沒有編程的膠水。我甚至不知道如何在這裏做一個文本看起來像一個Excel列表。對不起。 我的問題是，我必須將我們公司每個成員的電話號碼插入Access數據庫，並將excle文件分發給每個成員。 我每週都會收到一張名爲vodafone AUG_12（Vodafone actual month_year）的excel工作表，其中有超過50000行和幾列。第一列包含幾個電話號碼，最後一列（I）包含第一列中每個撥號的費用。 例如：

PhoneNu  Date  Time  Int. Code City Code Destination Description Duration Costs 

123456789 20120829 08:15:00 0049  431   12456  Kiel   00:02:15 02.95 
123456789 20120829 08:17:00 0049  431   12456  Kiel   00:19.95 17.45 
234567890 20120829 09:15:22 0031  21   5632145  Lisbon  00:00:28 0.10 
234567890 20120829 17:25:00 0031  21   5632145  Lisbon  00:00:59 0.28 
345678901 20120829 00:13:31 00351  91   5896   Service  00:03:45 2.58 
345678901 20120829 06:45:13 00351  91   5896   Service  01:25:13 12.85

等

有沒有辦法複製的行，每個數字在它具有數名新的工作簿，也把成本的總和，並將其保存在與原始文件夾相同的文件夾中。

Answer 1

你想分割這個50000記錄在個人否，然後爲每個獨特的否有一個工作表/工作簿，將包含所有的細節，然後計算成本？

如果是

- >使其更快，我會用C＃和鏈接通過ADO到Excel，但你說的編程是不是你的甜蜜點：d

- >使用VBA（它需要一些時間來完成）循環遍歷行，然後簡單地將整行復制到一個新的電話號碼爲no的工作表中。完成循環後，通過工作表並設置總和：獲取成本下方的最後一個單元格，並使用setformula來放置總和。

Answer 2

無論誰對此感興趣，您都可以在下面看到我的解決方案。這對我的數據文件運行大約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