Question

我试图将数据从一个文件夹中的多个工作簿复制到一个电子表格。该代码有效，除了我似乎无法对其进行调整以仅粘贴值。有人可以告诉我如何编辑“将“ SearchCaseResults”工作表上的数据复制到其他工作簿中的“争议”工作表”下的行，以便粘贴值，而不是公式，边框等。

Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "C:\Users\Ashton\Desktop\Control\"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("C:\Users\Ashton\Desktop\Control")
Set ws2 = y.Sheets("Sheet1")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
    With wb.Sheets("Timesheet")
        .Range("A9:B18").Copy ws2.Range("A" & Rows.Count).End(xlUp)
        .Range("B4").Copy ws2.Range("C" & Rows.Count).End(xlUp)
        .Range("S9:S18").Copy ws2.Range("D" & Rows.Count).End(xlUp)
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 1

您可以使用复制和粘贴特殊功能来完成它-您必须在两行上完成它。

您当前的代码将覆盖上一次使用的单元格，因此我添加了offset(1)。

With wb.Sheets("Timesheet")
    .Range("A9:B18").Copy
    ws2.Range("A" & Rows.Count).End(xlUp).offset(1).pastespecial xlvalues
    .Range("B4").Copy
    ws2.Range("C" & Rows.Count).End(xlUp).offset(1).pastespecial xlvalues
    .Range("S9:S18").Copy
    ws2.Range("D" & Rows.Count).End(xlUp).offset(1).pastespecial xlvalues
End With

更有效地，您可以直接传输值（尽管您也必须指定目标范围的大小）。

    With wb.Sheets("Timesheet")
        with .Range("A9:B18")
              ws2.Range("A" & Rows.Count).End(xlUp).offset(1).resize(.rows.count,.columns.count).value=.value
        End with
       'etc
    End With

从多个工作簿中提取数据到一个工作表

1 个答案: