Question

我有一个看起来像这样的主文件。工作表被称为＆＃34; Paylist＆＃34;。

     A        B
1    ID     Value
2   2902    
3   2928    
4   1777    
5   2707    
6   2746    
7   1224    
8   2068    
9   2937    
10  2709    
11  2903    
12  2579    
13  2926

我想带来与每个ID相对应的值（B列）。这可以从许多文件（看起来都相同）中获得，因为每个ID都有一个单独的文件。在这个文件中，ID始终位于单元格＆＃34; D5＆＃34;和细胞上的价值＆＃34; F19＆＃39;，第一工作表。

所以我必须遍历每张纸，复制单元格值＆＃34; F19＆＃34;然后将其粘贴到主文件中，在两个文件中的ID匹配的行上。

我知道如何循环浏览文件。

如何粘贴到正确的单元格，如何在主文件和其他文件之间切换？

这是我的代码。我的想法是尝试找到我应该使用Match粘贴值的行号。我在切换文件时遇到困难而且我不想将主文件限制为某个名称，因为它不会总是相同。

Sub Paylist()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim LastRow As Long, lastcolumn As Long
Dim eRow As Long

'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 = "Select A Target Folder"
    .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)

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

    'Copy cell F19

    wb.Worksheets(1).Range("F19").Copy
   Application.DisplayAlerts = False

    'Paste values - I know this is really bad here, but I think you get the idea of what I wanted to do

    eRow = MATCH(wb.Worksheets(1).Range("D5"),R1C1:R2500C1,0)

    ActiveSheet.Paste Destination:=Worksheets("Paylist").Cells(eRow, 2)

    'Close Workbook
    wb.Close

    '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

如果您的播放列表表来自不同的工作簿，则需要在粘贴之前激活工作簿。

wb.Worksheets(1).Activate
wb.Worksheets(1).Range("F19").Copy
Application.DisplayAlerts = False
Workbooks("UrPlaylistSheetWorkbook").Sheets("Playlist").Activate  
eRow = MATCH(wb.Worksheets(1).Range("D5"),R1C1:R2500C1,0)
Cells(eRow, 2).Select
ActiveSheet.Paste

循环遍历许多文件并复制粘贴

1 个答案: