VBA中合并单元的问题

Question

I have many many Excel workbooks (Excel files) and I have to open each one, because they are from different suppliers. In the active workbook I always need the cells GH327, GH 356, GH358, GH360 (GH cells are merged).

This are multiple Excel files, thats why we cannon put a name of the file in the code. Copy value from this document GH327, GH 356, GH358, GH360

And I have to copy this GH327, GH 356, GH358, GH360 to another Excel document in F, G, H, I (F are kg, G,H,I are cm). This is the end document:

Here is a macro with the button that should copy the values from first document. This does not yet work. It copies the value from this Excel file, not the first.

Then I click on the cell I want and press ENTER - then it paste the value - this works!

Code:

MODULE1

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

MODUL2

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

This code might work for you with some tweeks. Make sure all the xlsm files are in the same folder:

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

So this just pastes the four values to your final sheet on a new row but you'll have to include how to fill the other columns I assume.

Good luck!