Macro to Copy Cells From One Workbook into Another as Text

'WORKBOOKS W/MULTIPLE SHEETS MERGED INTO SHEETS IN CONSOLIDATION WORKBOOK
Here's a macro for collecting data from all sheets in all files in a specific folder merging into matching sheets.

Workbooks to Sheets - Part 4

The parts of the code that need to be edited are colored to draw your attention.

================
To copy from row11 and then paste as values, you'd need to change this one line of code:

                    .Range("A2:A" & LR).EntireRow.Copy wsMain.Range("A" & NR)

to these lines of code, this also changes the original workbook to values only:

                    .Range("A11:A" & LR).EntireRow.Copy 
                     wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .UsedRange.Copy
                    .Range("A1").PasteSpecial xlPasteValues

To save the original file with other filenames would be a change here:

            wbData.Close False

to this, perhaps:

            fName = Left(fName, InStrRev(fName, ".") - 1) & "1.xlsx"
            wbData.SaveAs fPath & fName, FileFormat:=51
            wbData.Close False

I think this is a patently bad idea, by they way. You're in the process of cycling through files in a folder and then you start adding files to that folder.... I bet this macro would run out of control.

I'd recommend you have a folder INSIDE this folder called "Values" and you save these new copies into that folder instead.

            fName = Left(fName, InStrRev(fName, ".") - 1) & "1.xlsx"
            wbData.SaveAs fPath & "\Values\" & fName, FileFormat:=51
            wbData.Close False

No, the macro is grabbing files "one at a time" from the folder you designate. If the number of files in that SAME folder were to get bigger and bigger as the macro proceeds, it would never end. It would eventually start finding the files you had just added and open them and do the same thing... kind of crazy.

I suppose you could test each filename before you open it to make sure it doesn't have "1.xlsx" in the filename....

But I'd still save new files to a different folder to not mix them.

Hey Jerry,

I followed the directions for #4 in the linked site and made the edits recommended above. In the process I went with your suggestion and created a "values" folder so the macro would not run endlessly. I then created a master file in the same folder as the data files, opened that one, created 4 tabs, named them as they're named in the individual files, and ran the macro (which is saved in a different file that contains all of my macros) and it returned an error that reads "Run-time error '9': Subscript out of range."

Here is the code, with the problem (as identified by the debugger) in yellow font:

Dim wbData As Workbook, wbMain As Workbook
    Dim wsMain As Worksheet, wsData As Worksheet
    Dim LR As Long, NR As Long
    Dim fPath As String, fName As String

    Set wbMain = ThisWorkbook

                                    'if files are stored in separate directory edit fPath
    fPath = ThisWorkbook.Path & "\"     'don't forget the final \
                                    
    fName = Dir(fPath & "*.xlsx")        'start looping through files one at a time
    Application.ScreenUpdating = False

    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then
            Set wbData = Workbooks.Open(fPath & fName)
            For Each wsData In wbData.Worksheets
                Set wsMain = wbMain.Sheets(wsData.Name)
                NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
                With wsData
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                     wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .UsedRange.Copy
                    .Range("A1").PasteSpecial xlPasteValues
                End With
            Next wsData
            
            fName = Left(fName, InStrRev(fName, ".") - 1) & "1.xlsx"
            wbData.SaveAs fPath & "\Values\" & fName, FileFormat:=51
            wbData.Close False
        End If
        
        fName = Dir                 'queue up next filename
    Loop

    Application.ScreenUpdating = True
End Sub

Any ideas??


Thanks again for your help.

My bad, this will probably need to be fixed, too:

wbData.SaveAs fPath & "Values\" & fName, FileFormat:=51

"Run-time error '9': Subscript out of range."

This means an named object cannot be found by the exact name specified. This is often due to simple misspellings, but other times to hidden spaces and such that make tab names LOOK the same but are not when examined very closely. You will need to identify the exact error in sheet tab names, because this is exactly what that error means.

send me your master file and a source file giving the error, I'll test it out.

Click GO ADVANCED and use the paperclip icon to post up a copy of your workbooks.

One would expect you replace sensitive data with junk data, whether sent privately or posted to the forum. To test this particular problem you could actually replace the data with absolute garbage since it's irrelevant. We're just trying to examine your sheet names and how the macro is coercing them.

Anyway, I took the two files above and the macro from further up and it worked bingo bango. Need to update this, though, never expect people to skip the top rows/columns, but some peeps, do...

                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues

Um, wouldn't your edited macro be in the Master? I don't see it installed there.

Maybe. THe original macro uses a THISWORKBOOK reference, I expected the macro to be installed in the Master. That's why the sheet names aren't matching up, it's looking at your other workbook.

Be sure to make the edit I noted above.

Have you tried using the autofilter? You can filter a column of data using the autofilter to only shows rows with a value of .8 or less (is less right?) before you copy and paste.

Heavens, no, you'd have the macro autofilter for you before the copy command.

Assuming the column to filter is column 13 (column M) the first row of data is row11 (apply filter to row 10), something like this:

                With wsData
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(10).AutoFilter
                    .Rows(10).AutoFilter Field:=13, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With

Hey Jerry,

The code you posted for this last part is fine, the problem is the column and row vary from sheet to sheet, which is completely my fault for not making them uniform. That being said I tried to work around it by writing that code into the part where I copy the "Cumulative Share Avg." value in each sheet (because in that part I go sheet by sheet), but it gave me the "Run-Time Error '91': Object Variable or With Block Variable Not Set" error. I've copied the code below with the portion the debugger highlights in yellow text. I think this is because at this point in the code WSMain has not been defined, I'm just not sure how to fix it.....

Sub CopyValuesToMaster()
'
' CopyValuesToMaster Macro This macro copies all of the individual TR files to a master district file as values so it's editable without blowing up the sheet
'

'
    Dim wbData As Workbook, wbMain As Workbook
    Dim wsMain As Worksheet, wsData As Worksheet
    Dim LR As Long, NR As Long
    Dim fPath As String, fName As String

    Set wbMain = ThisWorkbook

                                    'if files are stored in separate directory edit fPath
    fPath = ThisWorkbook.Path & "\"     'don't forget the final \
                                    
    fName = Dir(fPath & "*.xlsx")        'start looping through files one at a time
    Application.ScreenUpdating = False

    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then
            Set wbData = Workbooks.Open(fPath & fName)
    Sheets("Snuff").Select
    Range("Q12").Select
    ActiveCell.FormulaR1C1 = "=R8C13"
    Range("Q12").Select
    Selection.AutoFill Destination:=Range("Q12:Q1000"), Type:=xlFillDefault
    Range("Q12:Q1000").Select
                With ActiveSheet
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(11).AutoFilter
                    .Rows(11).AutoFilter Field:=12, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With
    Sheets("Cigars").Select
    Range("Q12").Select
    ActiveCell.FormulaR1C1 = "=R8C11"
    Range("Q12").Select
    Selection.AutoFill Destination:=Range("Q12:Q1000"), Type:=xlFillDefault
    Range("Q12:Q1000").Select
                With ActiveSheet
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(11).AutoFilter
                    .Rows(11).AutoFilter Field:=12, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With
    Sheets("LL").Select
    Range("K12").Select
    ActiveCell.FormulaR1C1 = "=R8C7"
    Range("K12").Select
    Selection.AutoFill Destination:=Range("K12:K1000"), Type:=xlFillDefault
    Range("K12:K1000").Select
                With ActiveSheet
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(11).AutoFilter
                    .Rows(11).AutoFilter Field:=6, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With
    Sheets("Snus").Select
    Range("K12").Select
    ActiveCell.FormulaR1C1 = "=R8C7"
    Range("K12").Select
    Selection.AutoFill Destination:=Range("K12:K1000"), Type:=xlFillDefault
    Range("K12:K1000").Select
                With ActiveSheet
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(11).AutoFilter
                    .Rows(11).AutoFilter Field:=6, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With
    Sheets("Overall ($)").Select
    Range("T11").Select
    ActiveCell.FormulaR1C1 = "=R8C7"
    Range("T11").Select
    Selection.AutoFill Destination:=Range("T11:T1000"), Type:=xlFillDefault
    Range("T11:T1000").Select
                With ActiveSheet
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                    .Rows(10).AutoFilter
                    .Rows(10).AutoFilter Field:=14, Criteria1:="<=0.8"
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A10:A" & LR).EntireRow.Copy
                    wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                End With
            For Each wsData In wbData.Worksheets
                Set wsMain = wbMain.Sheets(wsData.Name)
                NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
                With wsData
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                     wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                End With
            Next wsData
            
            fName = Left(fName, InStrRev(fName, ".") - 1) & "1.xlsx"
            wbData.SaveAs fPath & "Values\" & fName, FileFormat:=51
            wbData.Close False
        End If
        
        fName = Dir                 'queue up next filename
    Loop

    Application.ScreenUpdating = True
End Sub

Maybe this:

Option Explicit

Sub CopyValuesToMaster()
' This macro copies all of the individual TR files to a master district
' file as values so it's editable without blowing up the sheet
    
Dim wbData As Workbook, wbMain As Workbook
Dim wsMain As Worksheet, wsData As Worksheet
Dim LR As Long, NR As Long
Dim fPath As String, fName As String

Set wbMain = ThisWorkbook
NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1   'next empty row on main
fPath = ThisWorkbook.Path & "\"             'don't forget the final \

fName = Dir(fPath & "*.xlsx")               'start looping through files one at a time
Application.ScreenUpdating = False          'speed up macro by turning off screen

Do While Len(fName) > 0
    If fName <> ThisWorkbook.Name Then
        Set wbData = Workbooks.Open(fPath & fName)              'open the found file
            With wbData.Sheets("Snuff")                         'process a specific sheet
                LR = .Range("A" & .Rows.Count).End(xlUp).Row    'find last row with data
                .Range("Q12:Q" & LR).FormulaR1C1 = "=R8C13"
            End With
            With Sheets("Cigars")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row    'find last row with data
                .Range("Q12:Q" & LR).FormulaR1C1 = "=R8C11"
            End With
            With Sheets("LL")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row    'find last row with data
                .Range("K12:K" & LR).FormulaR1C1 = "=R8C7"
            End With
            With Sheets("Snus")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row    'find last row with data
                .Range("K12:K" & LR).FormulaR1C1 = "=R8C7"
            End With
            With Sheets("Overall ($)")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row    'find last row with data
                .Range("T11:T" & LR).FormulaR1C1 = "=R8C7"
            End With

            For Each wsData In wbData.Worksheets
                Set wsMain = wbMain.Sheets(wsData.Name)
                NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
                With wsData
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A11:A" & LR).EntireRow.Copy
                     wsMain.Range("A" & NR).PasteSpecial xlPasteValuesAndNumberFormats
                    .AutoFilterMode = False
                    .UsedRange.Copy
                    .UsedRange.PasteSpecial xlPasteValues
                End With
            Next wsData

            fName = Left(fName, InStrRev(fName, ".") - 1) & "1.xlsx"
            wbData.SaveAs fPath & "Values\" & fName, FileFormat:=51
            wbData.Close False
        End If

        fName = Dir                 'queue up next filename
    Loop

    Application.ScreenUpdating = True
End Sub

The goal in final tweaking is to remove all "selecting" and "Activating" and send all your commands to the target sheets/workbooks using your variables.