1

私はこれを迅速に保ちます。ほとんどの部分の添付コードは、他のプロジェクトでわずかなバリエーションを使用して動作します。コメントアウトされた range3.copy は、私の最後のプロジェクトからのものです。

現在、選択した範囲を正しいワークブックにコピーするために selection.copy を取得する際に問題が発生しています。スクリプトに記載されている多くのことを試しました。しかし、selection.copyを機能させることができません.range.copyが機能し、クリップボードに入力されます。しかし、.copy を使用して特別に貼り付ける方法がわかりません。

変数に出力しようとしました..思ったように機能しませんでした。ワークブックの選択/アクティベーションで何かが欠けているように感じますが、何がわかりません。アドバイスや支援をよろしくお願いします..プラグインを続けて、それを理解できるかどうかを確認します。

これが問題のある最初のセグメントです。SRCrange1.select then selection.copy は、指定された選択範囲を実際にはコピーしません。完全なコードは次のとおりです。

      Dim MyColumn As String
    Dim Here As String
    Dim AC As Variant

     'SRCrange1.copy  ': This will copy to clipboard

       'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
       'SRCrange1.Select 'the range does select
        'Selection.copy  '  this will cause a activecell in DSTwb _
        to be copied neither direct reference to SRCrange1.select or .avtivate will change that.


DSTwb.Select
             DSTwb.Range("b2").Select
             Here = ActiveCell.Address
             MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
             Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
             lastrow.Select
             Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

完全なコード 

Sub parse()
Dim strPath As String
Dim strPathused As String


'On Error Resume Next


Set objexcel = CreateObject("Excel.Application")
objexcel.Visible = True
objexcel.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 = objexcel.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 sourcebook
        Set SRCwb = objworkbook.Worksheets("plan")
        Set SRCrange1 = objworkbook.Worksheets("plan").Range("b6:i7")
        Set SRCrange2 = objworkbook.Worksheets("plan").Range("k6:p7")
        'Set SRCrange3 = objworkbook.Worksheets("").Range("")

'Range management sourcebook
        Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")
        'Set DSTrange1 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange2 = Workbooks("plancon.xlsx").Worksheets("data").Range("")
        'Set DSTrange3 = Workbooks("plancon.xlsx").Worksheets("data").Range("")

'start header dates and shifts copy from objworkbook to consolidated WB
                SRCwb.Select
                'On Error Resume Next
                'SRCwb.Cells.UnMerge

Dim MyColumn As String
Dim Here As String
Dim AC As Variant

 'SRCrange1.copy  ': This will copy to clipboard

   'objworkbook.Worksheets("plan").Range("b6:h7").Select  no change from SRCrange1.select
   'SRCrange1.Select 'the range does select
    'Selection.copy  '  this will cause a activecell in DSTwb _
    to be copied neither direct reference to SRCrange1.select or .avtivate will change that.
         DSTwb.Select
         DSTwb.Range("b2").Select
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True


   SRCrange2.Select
    Selection.copy
         Workbooks("plancon.xlsx").Worksheets("sheet1").Select
         ActiveSheet.Range("b2").Select
         ActiveSheet.Range("b2").Activate
         Here = ActiveCell.Address
         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
         lastrow.Select
         Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

'    range3.copy
'         Workbooks("data.xlsx").Worksheets("sheet1").Activate
'         ActiveSheet.Range("c2").Select
'         ActiveSheet.Range("c2").Activate
'         Here = ActiveCell.Address
'         MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)
'         Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)
'         ActiveSheet.Paste Destination:=lastrow


                    'start loop for objworkbook name copy to field in plancon corisponding with date/shift and copy/paste select row data.

    objworkbook.Close False
                        'Move proccesed file to new Dir

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

End If

Next

objexcel.Quit




End Sub
4

3 に答える 3

3

まず、SOへの相対的な歓迎！

次に、VBA プログラミングをより簡単に行うためのヒントをいくつか紹介します。

  1. Option Explicit を使用し、常に変数の型のディメンションと宣言を行います。
  2. 変数に名前を付けるときは、理解しやすく従いやすいものにしてください。したがって、ワークシート変数を作成する場合は、wksCopy のように呼び出します。または、ワークブックに名前を付ける場合は、wkbCopyTo と呼びます
  3. .Select と .Activate を使用する必要はありませんが、オブジェクトを直接操作できます。また、適切な変数の型を宣言することで、必要なときにコード内でこれらのオブジェクトを操作することがはるかに簡単になります。
  4. このコードを Excel 内で実行しているのか、別のアプリケーション (Access など) で実行しているのかはわかりませんが、Excel を使用している場合は、Excel アプリを直接操作できるため、Excel オブジェクトを作成する必要はありません。Access / Word / PPT などを使用してコードを起動している場合は、これを無視してください。

これらすべてのヒントにより、コードを読みやすく理解しやすくなり、デバッグや書き込みを行う際に従うことができます。

とはいえ、これらの原則のほとんどを組み込むために、上記のコードをリファクタリングしました (名前の変更で迷子にならないように、すべての変数名をそのままにしました)。この書き直しで問題が直接解決しない場合は、 = そうではないかもしれませんが、コードは書かれているように私にはややこしいので、デバッグするときに期待どおりに動作していない場所を追跡して理解し、見つけるのがはるかに簡単になると思います。また、わからないことがあればお教えいただけると助かります。

Sub parse()

    Dim strPath As String, strPathused As String
    Dim objexcel As Excel.Application

    Set objexcel = CreateObject("Excel.Application")
    With objexcel
        .Visible = True
        .DisplayAlerts = False
    End With

    strPath = "C:\prodplan"

    Dim objfso As FileSystemObject, objFolder As Folder

    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 Excel.Workbook
            Set objWorkbook = objexcel.Workbooks.Open(objfile.Path)

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

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

            'Range management sourcebook
            Dim SRCwb As Excel.Worksheet, SRCrange1 As Excel.Range, SRCrange2 As Excel.Range

            Set SRCwb = objWorkbook.Worksheets("plan") 'sjh -> to me wb implies wb, but you set it to a worksheet (could be a style thing, but worth pointing out
            Set SRCrange1 = objWorkbook.Worksheets("plan").Range("b6:i7")
            Set SRCrange2 = objWorkbook.Worksheets("plan").Range("k6:p7")


            'Range management sourcebook
            Set DSTwb = Excel.Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

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

            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)


            'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

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

        End If

    Next

objexcel.Quit

End Sub

UPDATEこれをすべてExcelで実行している場合。以下のコードを使用してください。これをExcelから実行していない場合に備えて、両方のコードを回答に残しました。

Option Explicit

Sub parse()

    Application.DisplayAlerts = False

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

    Dim objfso As FileSystemObject, objFolder As Folder

    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 sourcebook
            Dim SRCwb As Worksheet, SRCrange1 As Range, SRCrange2 As Range

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

            'Range management sourcebook
            Dim DSTwb As Worksheet
            Set DSTwb = Workbooks("plancon.xlsx").Worksheets("data")

            'start header dates and shifts copy from objworkbook to consolidated WB
            Dim MyColumn As String
            Dim Here As String
            Dim AC As Variant

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

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Dim lastrow As Range
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange1.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            Here = Workbooks("plancon.xlsx").Worksheets("sheet1").Range("B2").Address
            MyColumn = Mid(Here, InStr(Here, "$") + 1, InStr(2, Here, "$") - 2)

           'sjh comment -> best to change "ActiveWorkbook" to the workbook referece you mean, like objWorkbook or the other workbook you have open
            Set lastrow = ActiveWorkbook.ActiveSheet.Range(MyColumn & "65536").End(xlUp).Offset(1, 0)

            SRCrange2.Copy
            lastrow.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True

            objWorkbook.Close False

            'Move proccesed file to new Dir

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

        End If

    Next

End Sub
于 2012-06-20T19:58:31.130 に答える
1

他の回答に追加するだけです：連続した範囲の場合、この操作にコピーを使用する必要はありません（特殊な貼り付け>>値+転置）

Sub CopyValuesTranspose()

    Dim rngCopy As Range, rngPaste As Range

    Set rngCopy = Range("A1:B10")
    Set rngPaste = Range("D1")

    rngPaste.Resize(rngCopy.Columns.Count, rngCopy.Rows.Count).Value = _
                                   Application.Transpose(rngCopy.Value)

End Sub
于 2012-06-20T23:53:02.423 に答える
0

範囲を直接コピーできる場合は、範囲を選択して選択範囲をコピーする必要はありません。

objworkbook.Worksheets("plan").Range("b6:h7").Copy
same_or_different_Range.PasteSpecial Paste:=xlPasteValues, _
    operation:=xlNone, skipblanks:=False, Transpose:=True
于 2012-06-20T19:49:26.133 に答える