vba Folderpicker选择文件以将文件名和数据粘贴到不同的工作簿中

Question

我的文件夹1包含12个文件（file.Name = a.xlsx, b.xlsx, c.xlsx...,l.xlsx）。 每个文件都有36列。 col（B1：AK1 = 1979,1980，...，2014）。

在folder2中，它由36个文件组成。 （1979.xlsx, ...2014.xlsx）。

我希望folder2中的每个文件列都包含来自folder1的相应数据并打印文件名，因此folder2中每个文件中的标题将为col(B1:M1): (a,b,c,d..,l)。

下面是我从各种讨论中修改的代码。它的工作正常，但看起来很高，有什么不必要或可以改进？另外，由于我使用filepicker而不是循环，是否需要在代码末尾设置MyFile = Dir？

Sub OpenWorkbookUsingFileDialog() 
Dim fDialog As FileDialog
Dim FileName As String
Dim FileChosen As Integer
Dim FileSelected As Variant
Dim Files As String, MyFile As String
Dim wbk As Workbook
Dim cell As Range, Rng As Range
Dim x As String, ecol As Integer
Dim Folderpath, file As String, StationName As String
Dim lngStart, lngEnd As Long

Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

fDialog.Title = "Please Select an Excel File"
fDialog.InitialFileName = "G:\Sony Pendrive\Data Baru\WaterLevel\WL Refine\"
fDialog.InitialView = msoFileDialogViewSmallIcons
fDialog.Filters.Clear
fDialog.Filters.Add "Excel Macros Files", "*.xlsx"

FileChosen = fDialog.Show
FileSelected = fDialog.SelectedItems(1)
MyFile = Dir(FileSelected)

lngStart = InStr(fDialog.SelectedItems(1), "Sg")
lngEnd = InStr(fDialog.SelectedItems(1), "edit")
StationName = Mid(fDialog.SelectedItems(1), lngStart, lngEnd - lngStart - 1)

If FileChosen <> -1 Then
MsgBox "You have choosen nothing"
Else
MsgBox "you have select " & Station
End If
Set wbk = Workbooks.Open(FileName:=FileSelected)
Set Rng = wbk.Worksheets("sheet6").Range("B1:AK1")
 For Each cell In Rng
 x = cell.Value
 wbk.Worksheets("sheet6").Range(cell.Offset(1, 0), cell.Offset(1, 0).End(xlDown)).Copy

 Folderpath = "G:\Sony Pendrive\Data Baru\Tahun\PasteTahun\"
    Files = Folderpath & x & ".xlsx"
    Workbooks.Open (Files)
    ActiveWorkbook.Worksheets("sheet1").Select
    ecol = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Cells(1, ecol + 1).Value = StationName
        ActiveSheet.Cells(2, ecol + 1).Select
        ActiveSheet.Paste
        ActiveWorkbook.Close savechanges:=True

   Next cell
   MsgBox "done with " & wbk.Name
   wbk.Close savechanges:=True
   MyFile = Dir 'DIR gets the next file in the folder

   End Sub

提前谢谢。