Consulting

Results 1 to 11 of 11

Thread: Copying Same Range in Multiple Workbooks Worksheets to Columns in a Master Workbook

  1. #1

    Copying Same Range in Multiple Workbooks Worksheets to Columns in a Master Workbook

    Dear Experts
    I have tried to put together various bits of code from examples to do as described below but being a newbie, I have not been successful. I am getting an error that says object not support this property or method but I know that there are others. I am way over my head but I am learning and this is the exciting part.

    Here is what I would like to do:

    1. Using an identified path containing that have the required workbook files, open the workbooks, then go through each worksheet and copy the specified range of cells ( this range is the same for each worksheet - C3-C10).
    These copied ranges would then be pasted into adjacent columns of a specific worksheet ( GraphData) of a master workbook (MasterGen).

    I do have some additional conditions that I do not know how to do:
    1. When using MacOs (mac), how do you specify the path for the "Const sPath"?
    2. How do I specify that the "Definition" worksheet to be excluded from the selection, for both the workbooks sources and the master? I have tried to code this.
    3. How can I title each copied column in the master with the source worksheet name?

    Option Explicit 
    Sub CombineMultipleFiles() 
        Const sPath = "c:\" 
         
        Dim sFile As String 
        Dim wbkSource As Workbook 
        Dim wSource As Worksheet 
        Dim wTarget As Worksheet 
        Dim lColumns As Long 
        Dim lMaxSourceColumn As Long 
        Dim lMaxTargetColumn As Long 
         
        On Error GoTo ErrHandler 
        Application.ScreenUpdating = False 
         
        Set wTarget = ActiveWorkbook.Worksheets("GraphData") 
        lColumns = wTarget.Columns.Count 
        sFile = Dir(sPath & "*.xls*") 
        Do While Not sFile = "" 
            Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
            For Each wSource In wbkSource.Worksheets 
                If wSource.Name <> wSource("Definition") Then 
                    lMaxSourceColumn = wSource.Cells(lColumns, 1).End(xlUp).Column 
                    lMaxTargetColumn = wTarget.Cells(1, lColumns).End(xlToLeft).Column 
                    wSource.Range("C3:C10").Copy Destination:=wTarget.Cells(lMaxTargetColumn + 1, 3) 
                    wbkSource.Close SaveChanges:=False 
                    sFile = Dir 
                End If 
            Next 
        Loop 
         
    ExitHandler: 
        Application.ScreenUpdating = True 
        Exit Sub 
         
    ErrHandler: 
        MsgBox Err.Description, vbExclamation 
        Resume ExitHandler 
    End Sub 
    
    
    Formatting tags added by mark007
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  2. #2
    VBAX Master mancubus's Avatar
    Joined
    Dec 2010
    Location
    where i lay my head is home
    Posts
    2,362
    upload MasterGen.xlsm with the desired output.

    as i am attending a 2-day seminar, i may not be around but i am sure other helpers on this forum will give you the pointers to resolve your requirement.
    Posting Code
    [ CODE ]PasteYourCodeHere[ /CODE ]
    (or paste your code, select it, click # button)

    Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific, sensitive data with representative data.

  3. #3
    Great. Thank you for looking at when you return. I have reposted the updated Master file that has the outcomes expected when the macro runs
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  4. #4
    VBAX Master mancubus's Avatar
    Joined
    Dec 2010
    Location
    where i lay my head is home
    Posts
    2,362
    1 it's the same file
    2 i cant consolidate values as in your workbooks

    before consolidation
    20
    23
    18
    10
    15
    25
    8
    4

    after consolidation
    y
    t
    r
    e
    x
    c
    d

    3 manually do athe things you have requested with these two files in MasterGen.

    4 post your workbook with the desired output here.
    Posting Code
    [ CODE ]PasteYourCodeHere[ /CODE ]
    (or paste your code, select it, click # button)

    Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific, sensitive data with representative data.

  5. #5
    Dear mancubus
    Your time and effort are much appreciated! This is driving me crazy since I do not possess the skills. But I am eager.
    I apologize for incorrectly posting the master file that did not have the outcomes. It is now attached.
    You can well imagine the issues with handling up to 20 files with multiple sheets. This has all been done manually.
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  6. #6
    VBAX Master mancubus's Avatar
    Joined
    Dec 2010
    Location
    where i lay my head is home
    Posts
    2,362
    i am not an expert on Mac, and i dont have MSO for Mac installed on my machine. therefore i cant test it right now.

    Google is my best friend here.

    so test it with a copy of your file.

    Sub vbax_57678_cons_multi_ws_wb_mac() 
         
        Dim sPath As String, sFile As String 
        Dim wbkSource As Workbook 
        Dim wSource As Worksheet, wTarget As Worksheet 
         
        Application.ScreenUpdating = False 
         
        Set wTarget = ThisWorkbook.Worksheets("GraphData") 
         
        sPath = "Macintosh HD:Users:kk:Desktop:Testexcel:" 
        ChDir sPath 
        sFile = Dir("") 
         
        Do While sFile <> "" 
            Workbooks.Open Filename:=sPath & sFile 
            With ActiveWorkbook 
                For Each wSource In .Worksheets 
                    If wSource.Name <> "Definition" Then 
                        Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1) 
                        PasteRng.Value = sFile & "_" & wSource.Name 
                        ws.Range("C3:C10").Copy 
                        PasteRng.Offset(1).PasteSpecial 
                    End If 
                Next wSource 
                .Close False 
            End With 
            sFile = Dir 
        Loop 
         
    End Sub 
    
    
    Formatting tags added by mark007
    Posting Code
    [ CODE ]PasteYourCodeHere[ /CODE ]
    (or paste your code, select it, click # button)

    Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific, sensitive data with representative data.

  7. #7
    Dear mancubus
    When I ran it on the mac, I had an unrecognized format file error.
    With my friend google, I discovered that mac excel has an issue with Dir and therefore looping. I will try it on my friends windows machine to see what happens until I can revise the code for the code. One solution is "In the macro we call GetFilesOnMacWithOrWithoutSubfolders function like this to fill the MyFiles string". See below for the code. I will also try this. If I may I do wish to respond back to you once I have tried these methods.
    1.Another option would be to just activate all the files but this is potentially a lot of files? Any suggestions here?

    As always, I thank you for all your great support.

    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFiltthankion:=0, FileNameFilterStr:="SearchString")

    This are the four arguments that you can set in the function call :

    'Level : 1= Only the files in the folder, 2 to ? levels of subfolders
    'ExtChoice :0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
    'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
    'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3

  8. #8
    VBAX Master mancubus's Avatar
    Joined
    Dec 2010
    Location
    where i lay my head is home
    Posts
    2,362
    this may give you a start. i am not sure.

    Sub vbax_57678_cons_multi_ws_wb_mac() 
         'uses GetFilesOnMacWithOrWithoutSubfolders function from:
         'https://msdn.microsoft.com/en-us/library/office/jj613789(v=office.14).aspx
         
        Dim MyFiles As String 
        Dim Mybook As Workbook 
        Dim wSource As Worksheet, wTarget As Worksheet 
        Dim MySplit 
        Dim FileInMyFiles As Long, CalcMode As Long 
         
        With Application 
            CalcMode = .Calculation 
            .Calculation = xlCalculationManual 
            .ScreenUpdating = False 
            .EnableEvents = False 
        End With 
         
        Set wTarget = ThisWorkbook.Worksheets("GraphData") 
         
        MyFiles = "" 
         
        Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="") 
         'Level              :  1= Only the files in the folder you select, 2 to ? levels of subfolders
         'ExtChoice          :  0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
         'FileFilterOption   :  0=No Filter, 1=Begins, 2=Ends, 3=Contains
         'FileNameFilterStr  : Search string used when FileFilterOption = 1, 2 or 3
         
        If MyFiles <> "" Then 
            MySplit = Split(MyFiles, Chr(10)) 
            For FileInMyFiles = LBound(MySplit) To UBound(MySplit) - 1 
                Set Mybook = Workbooks.Open(MySplit(FileInMyFiles)) 
                With Mybook 
                    For Each wSource In .Worksheets 
                        If wSource.Name <> "Definition" Then 
                            Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1) 
                            PasteRng.Value = MySplit(FileInMyFiles) & "_" & wSource.Name 
                            wSource.Range("C3:C10").Copy 
                            PasteRng.Offset(1).PasteSpecial 
                        End If 
                    Next wSource 
                    .Close False 
                End With 
            Next FileInMyFiles 
        End If 
         
        With Application 
            .ScreenUpdating = True 
            .EnableEvents = True 
            .Calculation = CalcMode 
        End With 
         
    End Sub 
    
    
    Formatting tags added by mark007
    Posting Code
    [ CODE ]PasteYourCodeHere[ /CODE ]
    (or paste your code, select it, click # button)

    Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific, sensitive data with representative data.

  9. #9
    Dear mancubus

    Pure genius! I did some minor tweaking and it works like a charm. I previously failed to mention that the version of excel is Excel for Mac 2011 which has special needs for working around the file and directory. I have the code with all its tweaks that I did below. Now could I ask you for a big favour to tweak iit for those with Windows excel. I will be buying the Windows version, and Parallels to run it on the Mac to avoid these issues in the future.
    Thank you once again. I am so relieved and it is because of your persistence and skills.
    Sub Test() 
         
         
        Dim MyPath As String 
        Dim MyScript As String 
        Dim MySplit As Variant 
        Dim Mybook As Workbook 
        Dim OneFile As Boolean 
        Dim wSource As Worksheet, wTarget As Worksheet 
        Dim MyFiles As String 
        Dim FileInMyFiles As Long, CalcMode As Long 
         
        Set wTarget = ThisWorkbook.Worksheets("GraphData") 
        FileFormat = "{""org.openxmlformats.spreadsheetml.sheet""}" 
         
        OneFile = False 
    On Error Resume Next: 
        MyPath = "Macintosh HD:Users:kk:Desktop:Testexcel:" 
         
        If Val(Application.Version) < 15 Then 
             'This is Mac Excel 2011
            If OneFile = True Then 
                MyScript = _ 
                "set theFile to (choose file of type" & _ 
                " " & FileFormat & " " & _ 
                "with prompt ""Please select a file"" default location alias """ & _ 
                MyPath & """ without multiple selections allowed) as string" & vbNewLine & _ 
                "return theFile" 
            Else 
                MyScript = _ 
                "set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _ 
                "set theFiles to (choose file of type" & _ 
                " " & FileFormat & " " & _ 
                "with prompt ""Please select a file or files"" default location alias """ & _ 
                MyPath & """ with multiple selections allowed) as string" & vbNewLine & _ 
                "set applescript's text item delimiters to """" " & vbNewLine & _ 
                "return theFiles" 
            End If 
        End If 
         
        MyFiles = MacScript(MyScript) 
        On Error GoTo 0 
         
        If MyFiles <> "" Then 
            With Application 
                .ScreenUpdating = False 
                .EnableEvents = False 
            End With 
             
            MySplit = Split(MyFiles, Chr(10)) 
            If MyFiles <> "" Then 
                MySplit = Split(MyFiles, Chr(10)) 
                For FileInMyFiles = LBound(MySplit) To UBound(MySplit) 
                    Set Mybook = Workbooks.Open(MySplit(FileInMyFiles)) 
                    With Mybook 
                        For Each wSource In .Worksheets 
                            If wSource.Name <> "Definition" Then 
                                Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1) 
                                PasteRng.Value = wSource.Name 
                                wSource.Range("C3:C10").Copy 
                                PasteRng.Offset(1).PasteSpecial xlPasteValues 
                            End If 
                        Next wSource 
                        .Close False 
                    End With 
                Next FileInMyFiles 
            End If 
             
            With Application 
                .ScreenUpdating = True 
                .EnableEvents = True 
            End With 
            With Application 
                .ScreenUpdating = True 
                .EnableEvents = True 
            End With 
        End If 
    End Sub 
    
    
    Formatting tags added by mark007

  10. #10
    How would I convert this to run on the Windows platform?

  11. #11
    VBAX Master mancubus's Avatar
    Joined
    Dec 2010
    Location
    where i lay my head is home
    Posts
    2,362
    start your own thread in excel forum
    Posting Code
    [ CODE ]PasteYourCodeHere[ /CODE ]
    (or paste your code, select it, click # button)

    Uploading File(s)
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    Replace company specific, sensitive data with representative data.

Posting Permissions

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