2

VBAスキルが弱いサイトの初心者。私が何日も苦労してきた何かの助けを見つけることができることを願っています. 私は多くの例を見つけましたが、それらを一緒に結婚させることはできません. Excel 2007 を使用しています。「Summary_Reports」WB と、従業員が名前を付けた他のいくつかのワークブック (「Jim.xls」、「bob.xls」など) があります。各従業員ワークブックには、シート「Tasks」をソースとする名前付き範囲「caps」があります。各従業員 wb 内のこの名前付き範囲は、幅 (列数) は同じですが、高さ (行数) が異なる場合があり、一部の行が空になる場合があります。「Summary_Reports」wb にマクロを設定して、各従業員 wb を開き、名前付き範囲「caps」をコピーし、最初の列にデータを含むその範囲の行のみを挿入/貼り付けようとしています。「Summary_Reports」wb の「Report」シートに。最も簡単な貼り付け方法は、一番上のセルを選択して常にそこに行を挿入することだと思いました。そうすれば、各従業員は同じ場所から始まる前の行の上に挿入されます。そうすれば、シートに最後に入力された行を数えたり探したりする必要はありません。最初に "Jim.xls" を開いて名前付き範囲をワークブックから直接コピーしようとしましたが、ほとんど成功せず、構文に多くの問題がありました。そのため、従業員シートを「Summery_Reports」に取り込み、別の wb ではなくそれ自体から名前付き範囲をコピーする以下のコードになりました。おそらく最後にそれらのシートを削除してしまうでしょう。最も簡単な貼り付け方法は、一番上のセルを選択して常にそこに行を挿入することだと思いました。そうすれば、各従業員は同じ場所から始まる前の行の上に挿入されます。そうすれば、シートに最後に入力された行を数えたり探したりする必要はありません。最初に "Jim.xls" を開いて名前付き範囲をワークブックから直接コピーしようとしましたが、ほとんど成功せず、構文に多くの問題がありました。そのため、従業員シートを「Summery_Reports」に取り込み、別の wb ではなくそれ自体から名前付き範囲をコピーする以下のコードになりました。おそらく最後にそれらのシートを削除してしまうでしょう。最も簡単な貼り付け方法は、一番上のセルを選択して常にそこに行を挿入することだと思いました。そうすれば、各従業員は同じ場所から始まる前の行の上に挿入されます。そうすれば、シートに最後に入力された行を数えたり探したりする必要はありません。最初に "Jim.xls" を開いて名前付き範囲をワークブックから直接コピーしようとしましたが、ほとんど成功せず、構文に多くの問題がありました。そのため、従業員シートを「Summery_Reports」に取り込み、別の wb ではなくそれ自体から名前付き範囲をコピーする以下のコードになりました。おそらく最後にそれらのシートを削除してしまうでしょう。そうすれば、シートに最後に入力された行を数えたり探したりする必要はありません。最初に "Jim.xls" を開いて名前付き範囲をワークブックから直接コピーしようとしましたが、ほとんど成功せず、構文に多くの問題がありました。そのため、従業員シートを「Summery_Reports」に取り込み、別の wb ではなくそれ自体から名前付き範囲をコピーする以下のコードになりました。おそらく最後にそれらのシートを削除してしまうでしょう。そうすれば、シートに最後に入力された行を数えたり探したりする必要はありません。最初に "Jim.xls" を開いて名前付き範囲をワークブックから直接コピーしようとしましたが、ほとんど成功せず、構文に多くの問題がありました。そのため、従業員シートを「Summery_Reports」に取り込み、別の wb ではなくそれ自体から名前付き範囲をコピーする以下のコードになりました。おそらく最後にそれらのシートを削除してしまうでしょう。

以下で始めたことはうまくいきますが、私が知っているデータ検証は正しくありません。間違っている場合は修正してください。ただし、「大文字」の左上のセルのみをチェックしています。コンテンツがある場合はすべての「キャップ」を貼り付け、その 1 つのセルが空の場合は何も貼り付けません。すべての行の最初の列をチェックするように検証を修正するにはどうすればよいですか?また、データを含む行を表示するにはどうすればよいですか?

また、最初にシートをインポートせずに、各従業員 wb から直接「caps」データを取得するより良い方法があることも知っています。それが簡単にできるのであれば、その点についてアドバイスをいただければ幸いです。

親切にも私を助けてくれるなら、コードをコピーして貼り付けるだけでなく、実際にコードが何をするのかを知りたいと思っているので、できるだけ控えめにしてください。前もって感謝します。

Sub Import_Sheets()
Application.Workbooks.Open ("jim.xls")
Workbooks("jim.xls").Activate
Sheets("Tasks").Copy After:=Workbooks("Summary_Report.xlsm").Sheets("Report")
Application.Workbooks("Jim.xls").Close

'Go to newly copied sheet and name it.
ActiveSheet.Name = "jim"

'Copy the "caps" named range.
With Range("Caps")
    If .Cells(1, 1).Value = "" Then
    Else
        Range("Caps").Select
        Selection.Copy
        Sheets("Report").Select
        Range("B2").Select
        Selection.Insert Shift:=xlDown
    End If
End With
End Sub
4

1 に答える 1

2

コメント付きコード:

Sub Import_Sheets()

    'Declare variables
    Dim wsDest As Worksheet 'This is the sheet that data will be pasted to
    Dim rngCaps As Range    'This is used to determine if there is a named range "Caps"
    Dim rngFound As Range   'This is used to loop through the first column in the named range "Caps"
    Dim rngSearch As Range  'This is used to determine where to search
    Dim rngCopy As Range    'This is used to store the rows with data that will be copied
    Dim strFirst As String  'This is used to store the first cell address to prevent an infinite loop
    Dim i As Long           'This is used to loop through the selected workbooks

    'Create an "Open File" dialogue for the user to choose which files to import
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear                          'Clear existing filters (if any)
        .Filters.Add "Excel Files", "*.xls*"    'Filter for Excel files
        .AllowMultiSelect = True                'Allow user to select multiple files at a time with Shift or Ctrl

        If .Show = False Then Exit Sub  'Pressed cancel, exit macro

        'The destination is this workbook, sheet 'Report'
        Set wsDest = ActiveWorkbook.Sheets("Report")

        'Turn off screenupdating.  This prevents "Screen Flickering" and allows the code to run faster
        Application.ScreenUpdating = False

        'Begin loop through selected files
        For i = 1 To .SelectedItems.Count

            'Open a selected file
            With Workbooks.Open(.SelectedItems(i))

                'Attempt to find a sheet named 'TimeEntry' with a named range "Caps"
                On Error Resume Next
                Set rngCaps = .Sheets("TimeEntry").Range("Caps")
                On Error GoTo 0 'Remove the On Error Resume Next condition

                'Was it able to set rngCaps successfully?
                If Not rngCaps Is Nothing Then
                    'Yes, proceed to find rows with data
                    'Define rngSearch which will be used to find rows with data
                    Set rngSearch = Intersect(rngCaps, rngCaps.Cells(1).MergeArea.EntireColumn)

                    'Use a find loop to only get rows with data
                    'We can do this by utilizing the wildcard *
                    'The .Resize(, 1) will make sure we are only looking in the first column of rngCaps
                    Set rngFound = rngSearch.Find("*", rngSearch.Cells(rngSearch.Cells.Count), xlValues, xlWhole)

                    'Was there a cell found with data?
                    If Not rngFound Is Nothing Then
                        'Yes, record this first cell's address to prevent infinite loop
                        strFirst = rngFound.Address

                        'Also start storing the rows where data was found
                        Set rngCopy = rngFound

                        'Begin the find loop
                        Do
                            'Add found rows to the rngCopy variable
                            Set rngCopy = Union(rngCopy, rngFound)

                            'Advance loop to the next cell that contains data
                            Set rngFound = rngSearch.Find("*", rngFound, xlValues, xlWhole)

                        'Exit the loop when we are back to the first cell
                        Loop While rngFound.Address <> strFirst

                        'Copy the rows with data and paste them into the next available row in the destination worksheet
                        Intersect(rngCaps, rngCopy.EntireRow).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)

                        'Clear rngFound and rngCopy to get ready for next workbook
                        Set rngFound = Nothing
                        Set rngCopy = Nothing
                    End If

                    'Clear rngCaps to get ready for next workbook
                    Set rngCaps = Nothing
                End If

                'Close this opened workbook and don't save changes
                .Close False
            End With

        'Advance to the next workbook that was selected
        Next i

        'Re-enable screen updating
        Application.ScreenUpdating = True

        'Object variable cleanup
        Set wsDest = Nothing

    End With

End Sub
于 2013-08-22T18:59:08.210 に答える