Copy data from folder files to 1 workbook

[Montim]

Hi all,

i want to copy data from multiple files in a folder to 1 workbook like this:


Workbook input1:

Workbook input2:

Output merged data excel:

Any help would be very much appreciated. Sorry if it is not explained very well

​

 

[Montim]

Output to want.xlsm = what i want
Output Development.xlsm = can browse folder with pop up window; scanning all xlsx files in folder; copy specified ranges to active workbook but strange, because it works only for last columns arrange, but for last row it doesnt

 

[mumps]

In the "Input" files, will there always be 8 items in Group 1 and 3 items in Group 2 or can the number of items vary?

 

[Montim]

In the "Input" files, will there always be 8 items in Group 1 and 3 items in Group 2 or can the number of items vary?

Thanks your time, but im done now with 3 macros:

1. First i got xls, so convert:
Sub Xls_to_xslx_convert()


Dim strCurrentFileExt As String
Dim strNewFileExt As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim xlFile As Workbook
Dim strNewName As String
Dim strFolderPath As String


strCurrentFileExt = ".xls"
strNewFileExt = ".xlsx"


strFolderPath = "C:\temp"
If Right(strFolderPath, 1) <> "" Then
strFolderPath = strFolderPath & ""
End If


Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolderPath)
For Each objFile In objFolder.Files
strNewName = objFile.Name
If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
Set xlFile = Workbooks.Open(objFile.Path, , True)
strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt)
Application.DisplayAlerts = False
Select Case strNewFileExt
Case ".xlsx"
xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook
Case ".xlsm"
xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled
End Select
xlFile.Close
Application.DisplayAlerts = True
End If
Next objFile


ClearMemory:
strCurrentFileExt = vbNullString
strNewFileExt = vbNullString
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
Set xlFile = Nothing
strNewName = vbNullString
strFolderPath = vbNullString
End Sub


2. I deleted the blank rows between group1 and group 2, because i not figured out how can i make union range with pastespecial:
Sub Rows_Delete()
Dim sFldr As String
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.file
Dim fsoFldr As Scripting.Folder


Set fso = New Scripting.FileSystemObject


sFldr = "C:\Temp"


Set fsoFldr = fso.GetFolder(sFldr)


For Each fsoFile In fsoFldr.Files


Workbooks.Open fileName:=fsoFile.Path
Rows("A38", "A39", "A40").Select
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.Save
ActiveWindow.Close
Next fsoFile


End Sub



3. And the last is merge data to master workbook with fill (all filling cell ranges not in the code yet):
Sub Merge_Data()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim fileName As String
Dim ws As Worksheet
Dim counter As Long





' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet

'Select Folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "C:\temp"
If .Show = -1 Then
FolderPath = .SelectedItems(1) & ""
Else
Exit Sub 'User Canceled
End If
End With

' Call Dir the first time, pointing it to all Excel files in the folder path.
fileName = Dir(FolderPath & "*.xlsx*")

Application.ScreenUpdating = False
' Loop until Dir returns an empty string.
Do While fileName <> ""
' Open a workbook in the folder
With Workbooks.Open(FolderPath & fileName)

' Set the source worksheet
Set ws = Nothing
On Error Resume Next
Set ws = .Sheets("Bescheinigung ")
On Error GoTo 0

If Not ws Is Nothing Then

Rows("38:40").Select
Selection.Delete Shift:=xlUp

NextRow = SummarySheet.Range("A" & Rows.Count).End(xlUp).Row + 28
' NextRow2 = SummarySheet.Range("A" & Columns.Count).End(xlRight).column + 10



' Copy over the values from the source to the destination next row.

'Personal number
ws.Range("B5").Copy
SummarySheet.Range("A" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
'Name
ws.Range("B4").Copy
SummarySheet.Range("B" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
'Monatszahlungen First table
ws.Range("A10:A37").Copy
SummarySheet.Range("C" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=False
'Sachbezüge Second table
'ws.Range("A42:A43").Copy
SummarySheet.Range("C" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=False
'Certificate valid from/to
ws.Range("G5").Copy
SummarySheet.Range("D" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
'Währungen First table
ws.Range("N10:N37").Copy
SummarySheet.Range("F" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=False
'Währungen Second table
'ws.Range("N42:N43").Copy
SummarySheet.Range("F" & NextRow).PasteSpecial Paste:=xlPasteValues, Transpose:=False





counter = counter + 1
End If

' Close the source workbook without saving changes.
.Close SaveChanges:=False
End With

' Use Dir to get the next file name.
fileName = Dir()
Loop
Application.ScreenUpdating = True



'Rows delete
Rows("1:28").Select
Selection.Delete Shift:=xlUp

'Empty cells fill
'range("A1:A28", "A29:A56", "A58.Select
'Selection.FillDown
'range("B1:B28").Select
'Selection.FillDown
'range("D1:D28").Select
'Selection.FillDown

'Date row split and convert
Columns("D:D").Select
Selection.NumberFormat = "m/d/yyyy"
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, OtherChar _
:=" ", FieldInfo:=Array(Array(1, 4), Array(2, 9), Array(3, 4)), _
TrailingMinusNumbers:=True


'Message Box at finish
MsgBox counter & " Beillesztés készen van. ", , "Beillesztés készen van"


' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit


End Sub

 

[Montim]

In the "Input" files, will there always be 8 items in Group 1 and 3 items in Group 2 or can the number of items vary?

Sorry for not respondig, i used Dim (dimension) command in my life too, to figuring out how can i solve :D