VBA中合並單元的問題

Question

我有很多Excel工作簿（Excel文件），我必須打開每個工作簿，因為它們來自不同的供應商。 在活動工作簿中，我始終需要單元格GH327，GH 356，GH358，GH360（合並GH單元格）。

這是多個Excel文件，這就是為什么我們無法在代碼中放入文件名。 該文檔的復制值GH327，GH 356，GH358，GH360

而且我必須將此GH327，GH 356，GH358，GH360復制到F，G，H，I（F為kg，G，H，I為cm）中的另一個Excel文檔中。 這是最終文件：

這是帶有按鈕的宏，應該從第一個文檔中復制值。 這還行不通。 它從此Excel文件而不是第一個文件中復制值。

然后，單擊所需的單元格，然后按ENTER鍵-然后將其粘貼到該值中-這有效！

碼：

模塊1

Sub test()
ReDim arr(1 To 1, 1 To 4)
arr(1, 1) = Range("G327")
arr(1, 2) = Range("G356")
arr(1, 3) = Range("G358")
arr(1, 4) = Range("G360")
With Sheets("Helper")
.Range("A1").CurrentRegion.ClearContents
.Range("A1").Resize(, 4) = arr
.Range("A1").CurrentRegion.Copy
End With
End Sub

模數2

Sub test()
Dim wb As Workbook
Set wb = Workbooks("B:\eLWIS_EK\NF_INT_-_Pflegeteam_INT    \Verpackungsanlagen\Gesamtliste ab LT 13.07.2017.xlsm")
ReDim arr(1 To 1, 1 To 4)
arr(1, 1) = Range("G327")
arr(1, 2) = Range("G356")
arr(1, 3) = Range("G358")
arr(1, 4) = Range("G360")
wb.Sheets("Verpakungsgewichte").Range("F" &      Rows.Count).End(xlUp).Offset(1).Resize(, 4) = arr
End Sub     

Answer 1

這段代碼可能會在幾個星期內為您服務。 確保所有xlsm文件都在同一文件夾中：

Sub LoopAllExcelFilesInFolder()
'Loop through all Excel files in a user specified folder and perform a set task on them

Dim Currentwb As String
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 'Retrieve Target Folder Path From User
With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

NextCode: 'In case of Exit
Currentwb = ActiveWorkbook.Name
myPath = myPath
If myPath = "" Then GoTo ResetSettings

myExtension = "*.xlsm*" 'Target File Extension (must include wildcard "*")
myFile = Dir(myPath & myExtension) 'Target Path with Ending Extention

'Loop through each Excel file in folder
Do While myFile <> ""
    Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Set variable equal to opened workbook
    DoEvents 'Ensure Workbook has opened before moving on to next line of code
    'This line you might want to fill columns A-E
    Workbooks(Currentwb).Worksheets(1).Range("F" & Workbooks(Currentwb).Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row + 1).Value = wb.Sheets(1).Range("GH327").Value 'Paste your first parameter
    Workbooks(Currentwb).Worksheets(1).Range("G" & Workbooks(Currentwb).Worksheets(1).Range("G" & Rows.Count).End(xlUp).Row + 1).Value = wb.Sheets(1).Range("GH356").Value 'Paste your second parameter
    Workbooks(Currentwb).Worksheets(1).Range("H" & Workbooks(Currentwb).Worksheets(1).Range("H" & Rows.Count).End(xlUp).Row + 1).Value = wb.Sheets(1).Range("GH358").Value 'Paste your thrid parameter
    Workbooks(Currentwb).Worksheets(1).Range("I" & Workbooks(Currentwb).Worksheets(1).Range("I" & Rows.Count).End(xlUp).Row + 1).Value = wb.Sheets(1).Range("GH360").Value 'Paste your fourth parameter
    'This line you might want to fill columns J-L
    wb.Close SaveChanges:=False 'Close Workbook without saving
    DoEvents 'Ensure Workbook has closed before moving on to next line of code
    myFile = Dir 'Get next file name
Loop

ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

因此，這只是將這四個值粘貼到新行的最終工作表中，但是您必須包括如何填充我假設的其他列。

祝好運！