Page 2 of 2 FirstFirst 12
Results 11 to 14 of 14

Thread: Copy data from folder files to 1 workbook
Thanks Thanks: 0 Likes Likes: 0

  1. #11
    New Member
    Join Date
    May 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy data from folder files to 1 workbook

    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

  2. #12
    Board Regular mumps's Avatar
    Join Date
    Apr 2012
    Location
    Toronto, Canada
    Posts
    7,858
    Post Thanks / Like
    Mentioned
    83 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Copy data from folder files to 1 workbook

    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?
    Practice makes perfect. I'm very far from perfect so I'm still practising.

  3. #13
    New Member
    Join Date
    May 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy data from folder files to 1 workbook

    Quote Originally Posted by mumps View Post
    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

  4. #14
    New Member
    Join Date
    May 2019
    Posts
    9
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy data from folder files to 1 workbook

    Quote Originally Posted by mumps View Post
    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •