1

私のプログラムは、次のように多数のマクロを呼び出すことで機能します。

Sub Start()

Call ClearAll
Call Sales_Download
Call Copy_Sales
Call Receipt_Download
Call Copy_Receipt
Call Copy1
Call Sales_Summary
Call Copy2
Call Receipt_Summary

End Sub

私のプログラムは、基本的に正常に動作する copy1 の正確なレプリカである copy2 で中断します。copy2 を単独で実行すると完全に動作しますが、プログラム全体を実行しようとするとデバッグされます。太字の行は、デバッグが発生する場所です。

Sub Copy2()

 ' Copies all data from Receipt Download tab for each location, and saves in a seperate folder

Dim i As Long
Dim lngLastRow As Long, lngPasteRow As Long

'Find the last row to search through
lngLastRow = Sheets("Receipt_Download").Range("J65535").End(xlUp).Row

'Initialize the Paste Row
lngPasteRow = 2
Dim rng As Range
Dim c As Range
Dim endrow
Dim strName As String
Dim ws As Worksheet
Dim j As Long
endrow = Sheets("names").Range("A65000").End(xlUp).Row
Set rng = Sheets("names").Range("A2:A" & endrow)
j = 1
FBO = strName


For Each c In rng


For i = 2 To lngLastRow
    strName = c.Value
    If Sheets("Receipt_Download").Range("J" & i).Value = strName Then
        Sheets("Receipt_Download").Select
        Range("A" & i & ":IV" & i).Copy
        Sheets("Summary").Select
        Range("A" & lngPasteRow & ":IV" & lngPasteRow).Select
        ActiveSheet.Paste
        lngPasteRow = lngPasteRow + 1

    End If
Next i
j = j + 1
        Sheets("Receipt_Download").Select
        Rows("1:1").Select
        Selection.Copy
        Sheets("Summary").Select
        Rows("1:1").Select
        ActiveSheet.Paste
        Columns("D:E").Select
        Selection.NumberFormat = "m/d/yyyy"
        Sheets("Summary").Select
        Range("B25000").Select
        ActiveCell.FormulaR1C1 = "Grand Total"
        Range("B25000").Select
        Selection.Font.Bold = True
        Columns("G:G").Select
        Selection.Insert Shift:=xlToRight
        Range("G1").Select
        ActiveCell.FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
        Range("G1").Select
        Selection.AutoFill Destination:=Range("G1:G24950")
        Range("G25000").Select
        ActiveCell.FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
        Range("G25000").Select
        Selection.Copy
        Range("F25000").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Columns("G:G").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlToLeft
        Sheets("Summary").Select
        Range("F25000").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Names").Select
        With Columns("B")
        .Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
        End With
        ActiveSheet.Paste
        Sheets("Summary").Select
        Range("b1:b30000").Select
        For Each Cell In Selection
        If Cell.Value = "" Then
        Cell.ClearContents
        End If
        Next Cell
        Range("b1:b30000").Select
        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        Sheets("Summary").Select
        Range("D2").Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Names").Select
        ***With Columns("C")
        .Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate***
        End With
        ActiveSheet.Paste
        Sheets("Summary").Select
        Range("A1:Z5000").Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Range("A1").Select
        Application.CutCopyMode = False
        Selection.Copy
        Application.CutCopyMode = False
        File = "C:\Documents and Settings\user\Desktop\New FBO\" & strName & "\" & strName & " Receipts.xls"
        ActiveWorkbook.SaveAs Filename:=File, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close
        IngPasteRow = IngPasteRow + 1
        Sheets("Summary").Select
        Selection.ClearContents
Next c

End Sub

私は確かにVBAマスターではなく、これは非常に面倒でした。

4

2 に答える 2

2

コードのこの部分を置き換えます

 Sheets("Summary").Select
 Range("D2").Select
 Application.CutCopyMode = False
 Selection.Copy
 Sheets("Names").Select
 With Columns("C")
 .Find(what:="", after:=.Cells(1, 1), LookIn:=xlValues).Activate
 End With
 ActiveSheet.Paste

と

Dim lRow As Long

With Sheets("Names")
    lRow = .Range("C" & .Rows.Count).End(xlUp).Row + 1

    Sheets("Summary").Range("D2").Copy .Range("C" & lRow)
End With

今すぐ試してみてください。

また、いくつかのヒント

  1. 避け.Selectてください.Activate。これらはエラーの主な原因です
  2. コードをインデントし、適切にコメントしてください。あなたのコードは非常に読みにくいです。コードをインデント/コメントしないと、1週間後にアクセスすると自分のコードが認識されないことに気付くでしょう:)
于 2012-06-20T14:58:05.573 に答える
1

上記のシッダールスの答えを支持して、私はあなたのコードの一部を（ブレークが発生するところまで）取り、インデントして、彼が言及した.Selectandを避けました。.Activateこれにより、デバッグや理解のためにコードを読みやすくするための良いスタートが切れることを願っています。

For Each c In rng


    For i = 2 To lngLastRow

        strName = c.Value

        If Sheets("Receipt_Download").Range("J" & i).Value = strName Then

            Sheets("Receipt_Download").Range("A" & i & ":IV" & i).Copy _
                Destination:=Sheets("Summary").Range("A" & lngPasteRow & ":IV" & lngPasteRow)
            lngPasteRow = lngPasteRow + 1

        End If
Next i

j = j + 1

Sheets("Receipt_Download").Rows("1:1").Copy Destination:=Sheets("Summary").Rows("1:1")

With Sheets("Summary")

    .Columns("D:E").NumberFormat = "m/d/yyyy"

    With .Range("B25000")
        .Formula = "Grand Total"
        .Font.Bold = True
    End With

    .Columns("G:G").Insert Shift:=xlToRight

    With Range("G1")
        .FormulaR1C1 = "=IF(RC[-2]=0,""0"",RC[-1])"
        .AutoFill Destination:=Range("G1:G24950")
    End With

    With ("G25000")
        .FormulaR1C1 = "=SUM(R[-24950]C:R[-1]C)"
        .Copy
    End With

    .Range("F25000").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    .Columns("G:G").Delete Shift:=xlToLeft

    .Range("F25000").Copy Destination:=Sheets("Names").Columns("B").Find(what:="", after:=Sheets("Names").Cells(1, 1), LookIn:=xlValues)

End With
于 2012-06-20T15:05:38.723 に答える