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