Question

我尝试创建一个宏来将数据从不同工作簿的特定单元格/列复制到当前工作簿，但我需要在宏中添加更多步骤和更改，如下所述：

它应该询问excel文件的文件位置，并且在选择文件之后它应该为单元格范围选择，即从A3：D3。它应该将数据复制到所选单元格的末尾（从列的A3末端到D3末尾）。
复制上述数据后，应该像我在宏中一样，要求将单元格粘贴到当前工作簿中。
循环不应该在这里结束，我应该能够再次重复上述两个步骤，直到我完成从所需文件中复制所有数据。

这是我到目前为止所得到的：

Sub ImportDatafromotherworksheet()
Dim wkbCrntWorkBook As Workbook

Dim wkbSourceBook As Workbook

Dim rngSourceRange As Range

Dim rngDestination As Range

Dim row As Range

Dim row1 As Integer

Dim hello As Range

Dim hello1 As Range

Dim lastRow As Long, i As Long

Dim CopyRange As Range

Set wkbCrntWorkBook = ActiveWorkbook

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
    Workbooks.Open .SelectedItems(1)
    Set wkbSourceBook = Workbooks.Open(.SelectedItems(1))

    With wkbSourceBook.Worksheets(1)
        lastRow = .Range("A" & .Rows.Count).End(xlUp).row

    For i = 4 To lastRow
        If Len(Trim(.Range("A" & i).Value)) <> 0 Then
            If CopyRange Is Nothing Then
                Set CopyRange = .Rows(i)
            Else
            Set CopyRange = Union(CopyRange, .Rows(i))
            'Set MyRange = Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(6), Columns(8), Columns(10))
            Set MyRange = Range("a4:f4,k4,m4:n4,s4,u4:ab4")
            Set MyRange2 = MyRange.EntireColumn.Find("*", [a1], , , , xlPrevious)
            Set MyRange = Intersect(MyRange.EntireColumn, Rows(MyRange.row & ":" & MyRange2.row))
            'Set row = Columns("A,B,C,D,E")
            End If
        End If
    Next

    If Not CopyRange Is Nothing Then


        wkbCrntWorkBook.Activate
        Set rngDestination = Application.InputBox(Prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8)
        MyRange.Copy rngDestination
        'rngDestination.CurrentRegion.EntirdoeColumn.AutoFit
        wkbSourceBook.Close False
        '~~> Change Sheet2 to relevant sheet name
    End If
    End With


End If
End With

End Sub

我根据需要更改了代码。

Sub ImportTimeStudy1()
Dim myHeaders, e, x As Worksheet, wsMain As Worksheet
Dim wsImport As Workbook

Dim r As Range, c As Range


myHeaders = Array(Array("Branch Name", "Branch Name"), Array("Claim Number", `"Claim Number"), Array("ER contact Quality", "ER contact Quality"), ``Array("Adjuster Name", "Adjuster Name"))`


Set wsImport = Workbooks.Open("W:\YTD\Jul'15\Sarfaraj\Completed\Audit Report Test Junk.xlsx")

Set wsMain = ActiveWorkbook.Worksheets("Sheet 1")

For Each e In myHeaders

Set r = wsImport.Cells.Find(e(0), , , xlWhole)

If Not r Is Nothing Then
    Set c = wsMain.Cells.Find(e(1), , , xlWhole)

    If Not c Is Nothing Then
        wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
        wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
    Else
        msg = msg & vbLf & e(1) & " " & wsMain.Name
    End If
Else
    msg = msg & vbLf & e(0) & " " & wsImport.Name
End If

Next

If Len(msg) Then
MsgBox "Header not found" & msg

End If

Application.ScreenUpdating = False

End Sub

但现在问题是它无法正常工作并在以下情况下显示错误：设r = wsImport.Cells.Find（e（0）,,, xlWhole）

如果你可以帮助我纠正这个错误，那就太棒了。另外，不是为工作簿1提供固定路径，而是通过在驱动器上选择来输入路径。

将特定数据从一个工作簿复制到活动工作簿

0 个答案: