0

最初に、私はプログラミングの接着剤がまったくないと言わなければなりません。ここでテキストを Excel のリストのように表示する方法がわかりません。そのために残念。私の問題は、会社のすべてのメンバーの電話請求書を Access-Database に挿入し、excle ファイルも各メンバーに分散させなければならないことです。vodafone AUG_12 (Vodafone actual month_year) という名前の Excel ワークシートを毎週取得し、50000 を超える行といくつかの列が含まれています。最初の列にはいくつかの電話番号が含まれ、最後の列 (I) には最初の列の番号からの各ダイヤルのコストが含まれます。例えば：

PhoneNu Date Time Int. コード 市区町村 コード 目的地 説明 所要時間 費用

123456789 20120829 08:15:00 0049 431 12456 キール 00:02:15 02.95
123456789 20120829 08:17:00 0049 431 12456 キール 00:19.95 17.45
234567890 20120829 09:15:22 0031 21 5632145 リスボン 00:00:28 0.10
234567890 20120829 17:25:00 0031 21 5632145 リスボン 00:00:59 0.28
345678901 20120829 00:13:31 00351 91 5896 サービス 00:03:45 2.58
345678901 20120829 06:45:13 00351 91 5896 サービス 01:25:13 12.85

等

番号の名前を持つ新しいワークブックの各番号の行をコピーし、それにコストの合計も入れて、元と同じフォルダーに保存する方法はありますか。

4

2 に答える 2

1

興味のある方は、以下の私の解決策をご覧ください。これは、私のデータ ファイルに対して約 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
于 2013-01-23T08:53:23.890 に答える
0

この 50000 レコードを個々の番号に分割し、一意の番号ごとにすべての詳細を含むワークシート/ワークブックを作成してコストを計算しますか?

もし、そうなら

--> 高速化するために、C# とリンクを使用して ado を使用しますが、プログラミングはあなたの得意分野ではないとおっしゃいました:D

--> vba を使用します (完了するまでに時間がかかります) ループを作成して行を調べてから、電話番号の名前を持つ新しいワークシートに行全体をコピーするだけです。; ループが完了したら、ワークシートを調べて合計を設定します。コストの下の最後のセルを取得し、setformula を使用して合計を入力します。

于 2012-09-17T15:15:14.740 に答える