VBA code for copying ranges from multiple sheets to separate columns on new sheet

[CrishaG]

So I have workbooks that have varying numbers of sheets, which are named "S1", "S2", ... etc. until the final sheet "Sn". On each sheet in cell E7 is the named range of cells that need to be copied from that sheet. (i.e. C404:C1657 is in cell E7 on sheet S1, C403:C1587 is in cell E7 on sheet S2, etc.).

What I'd like is VBA code that copies the data from those ranges on each sheet, creates a new sheet called "JMP", and copies those ranges into separate columns on the JMP sheet with the name of the sheet as the first row in each column. So a workbook with 20 sheets will have a JMP sheet created with 20 columns of copied data with "S1", "S2" .... "S20" as the column title in row 1 of those columns.

Thank you!

 

[John_w]

Try this macro. You just need to edit the code where indicated to define the folder path and workbook file names to create the JMP sheets in.

Public Sub Create_JMP_Sheet_in_Workbooks()

    Dim matchWorkbooks As String
    Dim folderPath As String
    Dim wbFileName As String
    Dim targetWb As Workbook
    Dim s As Long, Sws As Worksheet
    Dim JMPws As Worksheet
    
    'Folder path and wildcard workbook files to create JMP sheets in
    
    matchWorkbooks = "C:\path\to\workbooks\*.xls*"                                'CHANGE THIS
    
    Application.ScreenUpdating = False
            
    folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))
    wbFileName = Dir(matchWorkbooks)
    
    While wbFileName <> vbNullString
    
        Set targetWb = Workbooks.Open(folderPath & wbFileName)
        
        'Add JMP sheet if it doesn't exist
        Set JMPws = Nothing
        On Error Resume Next
        Set JMPws = targetWb.Worksheets("JMP")
        On Error GoTo 0
        If JMPws Is Nothing Then
            Set JMPws = targetWb.Worksheets.Add(Before:=targetWb.Worksheets(1))
            JMPws.Name = "JMP"
        End If
        
        'Loop through Sn sheets and copy range in E7 to columns in JMP sheet
        s = 0
        Do
            s = s + 1
            Set Sws = Nothing
            On Error Resume Next
            Set Sws = targetWb.Worksheets("S" & s)
            On Error GoTo 0
            If Not Sws Is Nothing Then
                JMPws.Cells(1, s).Value = Sws.Name
                Sws.Range(Sws.Range("E7").Value).Copy JMPws.Cells(2, s)
            End If
        Loop While Not Sws Is Nothing
        
        targetWb.Close SaveChanges:=True
        DoEvents
        wbFileName = Dir
        
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub

 

[CrishaG]

Thank you so much for the code!

I got the following error.

Is there a way to do this that doesn't involve having to go into the VBA code and changing the folder path? This is going to be used multiple times for different projects in different folders, so I could see it being a hassle if we have to go into the code every time to modify the path. Maybe a pop-up asking for the path?

I will post my current VBA code that I've cobbled together from different places online that I would ideally like to insert the code you provided me. We get raw data from the Instron, and each sample outputs its own .csv file. The code takes all of the .csv files in the folder and inputs them as individual sheets in an excel file named "S1", "S2", etc. It then adds the MATCH function into "E7." The code below confirms to do all of this. I would then like to add the additional code you provided so that by the end I have an Excel sheet with all the MATCH range of data in individual columns.

I will say that starting the columns with S1, S2, etc. in the first row is a nice-to-have, not need-to-have, if that helps. It would just cut down on time having to name all of the columns in JMP when I paste the data into the software.

Thank you!

Sub CombineCsvFiles()  'Updated by MelCompton
' Combine csv files in folder into one Excel file
    Dim xFilesToOpen As Variant
    Dim I As Integer
    Dim xWb As Workbook
    Dim xTempWb As Workbook
    Dim xDelimiter As String
    Dim xScreen As Boolean
    
    On Error GoTo ErrHandler
    xScreen = Application.ScreenUpdating
    Application.ScreenUpdating = False
    xDelimiter = "|"
    xFilesToOpen = Application.GetOpenFilename("Text Files (*.csv), *.csv", , "MelCompton VBA for Excel", , True)
    
    If TypeName(xFilesToOpen) = "Boolean" Then
        MsgBox "No files were selected", , "MelCompton VBA for Excel"
        GoTo ExitHandler
    End If
    
    I = 1
    Set xTempWb = Workbooks.Open(xFilesToOpen(I))
    xTempWb.Sheets(1).Copy
    Set xWb = Application.ActiveWorkbook
    xTempWb.Close False
    
    Do While I < UBound(xFilesToOpen)
        I = I + 1
        Set xTempWb = Workbooks.Open(xFilesToOpen(I))
        xTempWb.Sheets(1).Move , xWb.Sheets(xWb.Sheets.Count)
    Loop
    
' Rename sheets and copy MATCH formulas in each worksheet
    Dim WS_Count As Integer
    Dim J As Integer

    ' Set WS_Count equal to the number of worksheets in the active workbook.
    WS_Count = ActiveWorkbook.Worksheets.Count

    ' Begin the loop.
    For J = 1 To WS_Count
        Application.Sheets(J).Name = "S" & J    ' Rename sheets to S1 thru S(WS_Count)
        With ActiveWorkbook.Worksheets          ' Add MATCH formulas to each worksheet
            .Item(1).Range("C5").Formula = "=MATCH(C4,A:A)"
            .FillAcrossSheets .Item(1).Range("C5"), xlFillWithAll
            .Item(2).Range("D5").Formula = "=MATCH(D4,A:A)"
            .FillAcrossSheets .Item(2).Range("D5"), xlFillWithAll
            .Item(3).Range("E7").Formula = "=""C""&MATCH(C4,A:A)&"":C""&MATCH(D4,A:A)"
            .FillAcrossSheets .Item(3).Range("E7"), xlFillWithAll
        End With
    Next J
    
ExitHandler:
    Application.ScreenUpdating = xScreen
    Set xWb = Nothing
    Set xTempWb = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Description, , "MelCompton VBA for Excel"
    Resume ExitHandler

End Sub

 

[CrishaG]

Also, when I used your code, I used it as its own module and changed the name of the folder path to the existing worksheet that was populated from my code above.

Public Sub Create_JMP_Sheet_in_Workbooks()

    Dim matchWorkbooks As String
    Dim folderPath As String
    Dim wbFileName As String
    Dim targetWb As Workbook
    Dim s As Long, Sws As Worksheet
    Dim JMPws As Worksheet
    
    'Folder path and wildcard workbook files to create JMP sheets in
    
    matchWorkbooks = "U:\Book1.xlsx"                                'CHANGE THIS
    
    Application.ScreenUpdating = False
            
    folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))
    wbFileName = Dir(matchWorkbooks)
    
    While wbFileName <> vbNullString
    
        Set targetWb = Workbooks.Open(folderPath & wbFileName)
        
        'Add JMP sheet if it doesn't exist
        Set JMPws = Nothing
        On Error Resume Next
        Set JMPws = targetWb.Worksheets("JMP")
        On Error GoTo 0
        If JMPws Is Nothing Then
            Set JMPws = targetWb.Worksheets.Add(Before:=targetWb.Worksheets(1))
            JMPws.Name = "JMP"
        End If
        
        'Loop through Sn sheets and copy range in E7 to columns in JMP sheet
        s = 0
        Do
            s = s + 1
            Set Sws = Nothing
            On Error Resume Next
            Set Sws = targetWb.Worksheets("S" & s)
            On Error GoTo 0
            If Not Sws Is Nothing Then
                JMPws.Cells(1, s).Value = Sws.Name
                Sws.Range(Sws.Range("E7").Value).Copy JMPws.Cells(2, s)
            End If
        Loop While Not Sws Is Nothing
        
        targetWb.Close SaveChanges:=True
        DoEvents
        wbFileName = Dir
        
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub

 

[John_w]

I got the following error.

Click Debug. What is the value of Sws.Range("E7").Value? Is it valid?

Is there a way to do this that doesn't involve having to go into the VBA code and changing the folder path?

You could include this folder browse code:

    matchWorkbooks = "*.xls*"
        
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

and delete this line:

folderPath = Left(matchWorkbooks, InStrRev(matchWorkbooks, "\"))

 

[CrishaG]

If I'm looking at it correctly, it says that the value is empty.

Also, I checked the Book1.xlsx workbook and the JMP worksheet was created and it has "S1" in cell A1, but nothing further.

Thank you!

 

[John_w]

The code expects E7 on every "Sn" sheet to contain a range string, as shown in your screenshot. What should it do if E7 is empty?

 

[CrishaG]

I figured out the issue. I was referencing the wrong file that didn't have any values in the "E7". I referenced the correct file and the script ran just fine.

I was able to modify your script to work in mine, so everything runs smooth.

Thank you very much!