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
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!
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.