0

私はこれを長い間見てきましたので、銅または知識が私に投げつけられることを期待して、より多くの経験を持つ人にそれを投げます. コードはエラーなしで実行されます。

問題は、最初のループの 2 番目のインクリメントが最初のインクリメント データ範囲をオーバーライドすることです。ループ 1 は、行 2:15 に入力します。lastrow のアドレスを見ると、貼り付ける列の lastrow/cell として b16 の正しい範囲が表示されます。行。何かばかげたことを見逃しているような気がしますが、それは私をほのめかしています。

ヘルプやアドバイスをいただければ幸いです。私はフィードバックに興味があるリレーです。これにより、最終的に 100 以上のワークブックが処理され、それぞれに約 1000 のエントリが追加されます。コードの効率が心配です。配列を使用すると速度が向上しますか? 物事が追いつくと、週に 2 つのワークブックしか処理されません。繰り返しますが、あなたが喜んで共有する指針やアドバイスに感謝します。

Option Explicit

Sub parse()

    Application.DisplayAlerts = False
    'Application.EnableCancelKey = xlDisabled

    Dim strPath As String, strPathused As String
    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder, objfile As Object

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)


    'Loop through objWorkBooks
    For Each objfile In objFolder.Files

        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Dim objWorkbook As Workbook
            Set objWorkbook = Workbooks.Open(objfile.Path)

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"


            'Range management WB
            Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range, lastrow As Range

            Set SRCwb = objWorkbook.Worksheets("plan")
            Set SRCrange1 = SRCwb.Range("b6:i7")
            Set SRCrange2 = SRCwb.Range("k6:p7")

            'Range management destination WB
            Dim DSTws As Worksheet
            Set DSTws = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB

            Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)

            SRCrange1.copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
            Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name


            Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)

            SRCrange2.copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
            Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name

            'Begin loop to copy content.
            Dim DSTheader As Range
            Set DSTheader = DSTws.Range("d1:bw1")
            Dim SRCheader As Range
            Set SRCheader = SRCwb.Range("a1:a110")

            Dim x As Variant
            Dim y As Variant

            Dim matchEXIT As Boolean
            matchEXIT = False

    For Each x In DSTheader
      For Each y In SRCheader

            Dim SRCrngCP1 As Range
            Set SRCrngCP1 = SRCwb.Range(y.Offset(0, 1).Address & ":" & y.Offset(0, 8).Address)
            Dim SRCrngCP2 As Range
            Set SRCrngCP2 = SRCwb.Range(y.Offset(0, 10).Address & ":" & y.Offset(0, 15).Address)

            If y > 0 Then

            If x = y Then

            Dim MyColumn As String
            Dim Here As String


            Here = DSTws.Range(x.Address).Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

            Set lastrow = DSTws.Range(MyColumn & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)

            SRCrngCP1.copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Set lastrow = DSTws.Range(MyColumn & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)

            SRCrngCP2.copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            If x = y Then matchEXIT = True
            If matchEXIT = True Then Exit For

    End If
    End If

        Next y

            matchEXIT = False
    Next x

     MsgBox x
            objWorkbook.Close False

            'Move proccesed file to new Dir
            Dim OldFilePath As String
            Dim NewFilePath As String

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file

        End If
            Set lastrow = Workbooks("plancon.xlsx").Worksheets("data").Range("b" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
    Next

End Sub
4

2 に答える 2

0

未テスト

これをテストして、エラーが発生したかどうか教えてください。

Option Explicit

Sub parse()
    Dim MyColumn As String, Here As String, OldFilePath As String, NewFilePath As String
    Dim strPath As String, strPathused As String

    Dim objfso As FileSystemObject, objFolder As Folder, objfile As Object

    Dim objWorkbook As Workbook, wbPlan As Workbook
    Dim SRCwb As Worksheet, DSTws As Worksheet

    Dim lastrow As Long, lastrowN As Long

    Dim SRCrange1 As Range, SRCrange2 As Range
    Dim DSTheader As Range, SRCheader As Range, x As Range, y As Range
    Dim SRCrngCP1 As Range, SRCrngCP2 As Range

    Application.DisplayAlerts = False

    strPath = "C:\prodplan"

    Set objfso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objfso.GetFolder(strPath)

    'Loop through objWorkBooks
    For Each objfile In objFolder.Files
        If objfso.GetExtensionName(objfile.Path) = "xlsx" Then

            Set objWorkbook = Workbooks.Open(objfile.Path)
            Set SRCwb = objWorkbook.Worksheets("plan")
            Set SRCrange1 = SRCwb.Range("B6:I7")
            Set SRCrange2 = SRCwb.Range("K6:P7")

            ' Set path for move to at end of script
            strPathused = "C:\prodplan\used\" & objWorkbook.Name

            'open WB to consolidate too
            Set wbPlan = Workbooks.Open("C:\prodplan\compiled\plancon.xlsx")
            Set DSTws = wbPlan.Worksheets("data")
            lastrow = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row + 1

            With DSTws.Range("B" & lastrow)
                SRCrange1.Copy
                .PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
                lastrowN = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row
                .Range("A" & lastrow & ":A" & lastrowN).Value = objWorkbook.Name

                lastrow = lastrowN + 1

                SRCrange2.Copy
                .PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
                lastrowN = DSTws.Range("B" & DSTws.Rows.Count).End(xlUp).Row
                .Range("A" & lastrow & ":A" & lastrowN).Value = objWorkbook.Name
            End With

            Set DSTheader = DSTws.Range("D1:BW1")
            Set SRCheader = SRCwb.Range("A1:A110")

            For Each x In DSTheader
                For Each y In SRCheader
                    Set SRCrngCP1 = SRCwb.Range(y.Offset(0, 1).Address & ":" & y.Offset(0, 8).Address)
                    Set SRCrngCP2 = SRCwb.Range(y.Offset(0, 10).Address & ":" & y.Offset(0, 15).Address)
                    If y > 0 Then
                        If x = y Then
                            Here = x.Address
                            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

                            lastrow = DSTws.Range(MyColumn & DSTws.Rows.Count).End(xlUp).Row + 1

                            With DSTws.Range("B" & lastrow)
                                SRCrngCP1.Copy
                                .PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

                                lastrow = DSTws.Range(MyColumn & DSTws.Rows.Count).End(xlUp).Row + 1

                                SRCrngCP2.Copy
                                .PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True
                            End With

                            If x = y Then Exit For
                        End If
                    End If
                Next y
            Next x

            objWorkbook.Close False

            OldFilePath = objfile 'original file location
            NewFilePath = strPathused ' new file location
            Name OldFilePath As NewFilePath ' move the file
        End If
    Next
End Sub
于 2012-06-22T06:50:19.717 に答える
0

さて、私はそれから離れて素敵な長い週末の後にそれを理解しました。当たり前の瞬間があった

 'open WB to consolidate too
            Workbooks.Open "C:\prodplan\compiled\plancon.xlsx"

それにコピーすることになっていたループ内で、各ループでコピーをWBにリセットし、上書きのように見えました。

開いている行を移動すると、ループによってペーストが最後のセルに問題なくインクリメントされます。しかし、それは壊れました

 Range(ActiveCell, Selection.End(xlDown)).Offset(0, -1).Value = objWorkbook.Name

ある種の..コードをf8ダウンすると、機能します..コードを実行すると、行がスキップされます..わからない....理解できない場合は、別の質問で再投稿します。

于 2012-06-25T12:49:53.397 に答える