Results 1 to 16 of 16

Thread: Sleeper: Copy Data from several Workbooks to Another Workbook

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Regular
    Joined
    Jun 2023
    Location
    Slovakia
    Posts
    9
    Location
    Could someone help me get this macro to work for Mac Microsoft 365?


    Sub Makro1()
    Application.ScreenUpdating = False
    DestBook = ActiveWorkbook.Name
    Files = Application.GetOpenFilename(FileFilter:="Excel files (*.xls*), *.xls*", Title:="Choose an Excel file to open", MultiSelect:=True)  
    If Not IsArray(Files) Then     
        Exit Sub  
    End If  
    For Each File In Files    
        Col = 4    
        Workbooks.Open (File)    
        SourceBook = ActiveWorkbook.Name        
        DoWhile = True        
            Do While DoWhile = True     
            Windows(DestBook).Activate     
            Sheets(1).Cells(1, Col).Select     
            If Selection.Text = "" Then        
                EndRow = 1        
                StartRow = 1        
            Else        
                Range(Selection, Selection.End(xlDown)).Select        
                EndRow = Selection.Rows.Count + 1        
                StartRow = 2     
            End If          
            ' Do col3 vlozi nazov suboru     
            If Col = 4 Then        
                ActiveSheet.Cells(EndRow, 3).Value = SourceBook     
            End If          
            Windows(SourceBook).Activate     
            ActiveSheet.Cells(StartRow, Col).Select     
            If Selection.Text = "" Then        
                Exit Do     
            End If     
            Range(Selection, Selection.End(xlDown)).Select     
            Selection.Copy     
            Windows(DestBook).Activate     
            ActiveSheet.Cells(EndRow, Col).Select     
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False     
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False     
            Selection.PasteSpecial Paste:=xlPasteColumnWidths          
            Col = Col + 1         
        Loop    
        Windows(SourceBook).Close    
        Application.ScreenUpdating = True    
        Windows(DestBook).Activate     
    Next            
    Application.ScreenUpdating = True
    End Sub
    Last edited by Aussiebear; 11-16-2023 at 05:33 AM. Reason: edited the code layout and added code tags to supplied code

Posting Permissions

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