Change range reference from fixed to last visible entry in copy/paste macro

[shotgun1]

Hi

I'm quite new to VBA coding and have got some code working thanks to Luke_M to copy and paste data from all my workbooks in a folder to a master sheet. However I can't figure out how to adjust the range that is selected to be only the visible filled cells rather than whole "C3:R13" range in each workbook which is a table.

Any help would be much appreciated

Set SummarySheet = Workbooks("Master Template").Worksheets(1)

' Modify this folder path to point to the files you want to use.
FolderPath = "C:\\My Documents\"

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 3

' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")

' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)

' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName

Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R13")


Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)

DestRange.Value = SourceRange.Value

DestRange.Offset(0, DestRange.Columns.Count).Resize(, 1).Value = WorkBk.Name

NRow = NRow + DestRange.Rows.Count

WorkBk.Close savechanges:=False

' Use Dir to get the next file name.
FileName = Dir()
Loop

SummarySheet.Columns.AutoFit
End Sub

 

[Luke M]

Hello again shotgun1.

Change this

Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R13")


Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)

to this:

Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R13").SpecialCells(xlCellTypeVisible)


Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Cells.Count / SourceRange.Columns.Count, _
SourceRange.Columns.Count)

The SpecialCells method lets us grab only the visible cells. We have to modify the DestRange definition a little bit as the Rows won't count properly when you have filtered rows. Thankfully, can do a math trick of counting number of cells and divide by number of columns (which gives us number of visible rows).

 

[shotgun1]

Many thanks for that Luke! Wouldn't have been able to figure myself!


Just a quick follow-up question. If I wanted to copy/paste other ranges can I wrap them in this macro by defining the setRange and DestRange etc again for the other ranges or would running as a separate macro be the way?

Hello again shotgun1.

Change this

Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R13")


Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)

to this:

Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R13").SpecialCells(xlCellTypeVisible)


Set DestRange = SummarySheet.Range("A" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Cells.Count / SourceRange.Columns.Count, _
SourceRange.Columns.Count)

The SpecialCells method lets us grab only the visible cells. We have to modify the DestRange definition a little bit as the Rows won't count properly when you have filtered rows. Thankfully, can do a math trick of counting number of cells and divide by number of columns (which gives us number of visible rows).

 

[Luke M]

I think you can do what you asked. To be honest, I'm not exactly sure by your phrasing what you meant. Can you post an example of the changed code?

 

[shotgun1]

I think you can do what you asked. To be honest, I'm not exactly sure by your phrasing what you meant. Can you post an example of the changed code?

This is what I've edited it to:

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long, Nrow2 As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range, SourceRange2 As Range
Dim DestRange As Range, DestRange2 As Range

Set SummarySheet = Workbooks("Master Template").Worksheets(1)

' Modify this folder path to point to the files you want to use.FolderPath = "C:\\My Documents\"

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 3
Nrow2 = 24

' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "BCE*.xl*")

' Loop until Dir returns an empty string.
Do While FileName <> ""
    ' Open a workbook in the folder
   Set WorkBk = Workbooks.Open(FolderPath & FileName)
   
    ' Set the cell in column A to be the file name.
   SummarySheet.Range("A" & NRow).Value = FileName
   
    ' Set the source range to be A9 through C9.
   ' Modify this range for your workbooks.
   ' It can span multiple rows.
   Set SourceRange = WorkBk.Worksheets("Pricing Summary").Range("C3:R" & Range("F" & Rows.Count).End(xlUp).Row)
   
    ' Set the destination range to start at column B and
   ' be the same size as the source range.
   Set DestRange = SummarySheet.Range("A" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
    SourceRange.Columns.Count)
   
    ' Copy over the values from the source to the destination.
   DestRange.Value = SourceRange.Value
   
    '====NEW ADDITION====
   DestRange.Offset(0, DestRange.Columns.Count).Resize(, 1).Value = WorkBk.Name
    '====END ADDITION====
    ' Increase NRow so that we know where to copy data next.
   NRow = NRow + DestRange.Rows.Count
   
    ' Close the source workbook without saving changes.
   WorkBk.Close savechanges:=False
   
    ' Use Dir to get the next file name.
   FileName = Dir()
Loop

Do While FileName <> ""
    ' Open a workbook in the folder
   Set WorkBk = Workbooks.Open(FolderPath & FileName)
   
    ' Set the cell in column A to be the file name.
   SummarySheet.Range("A" & NRow).Value = FileName
   
    ' Set the source range to be A9 through C9.
   ' Modify this range for your workbooks.
   ' It can span multiple rows.
   Set SourceRange2 = WorkBk.Worksheets("Pricing Summary").Range("B19:R" & Range("F" & Rows.Count).End(xlUp).Row)

   
    ' Set the destination range to start at column B and
   ' be the same size as the source range.
        Set DestRange2 = SummarySheet.Range("A" & Nrow2)
    Set DestRange2 = DestRange2.Resize(SourceRange2.Rows.Count, _
    SourceRange2.Columns.Count)
   
    ' Copy over the values from the source to the destination.

   DestRange2.Value = SourceRange2.Value
   
    '====NEW ADDITION====

   DestRange2.Offset(0, DestRange2.Columns.Count).Resize(, 1).Value = WorkBk.Name
    '====END ADDITION====
    ' Increase NRow so that we know where to copy data next.

   Nrow2 = Nrow2 + DestRange2.Rows.Count
   
   
   
    ' Close the source workbook without saving changes.
   WorkBk.Close savechanges:=False
   
    ' Use Dir to get the next file name.
   FileName = Dir()
Loop
  ' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub

 

[Luke M]

No, that way won't work.
But, I think I understand now what the overall question is. Looks like you want to copy multiple ranges from each workbook? However, I'm not sure about one thing. First range is going to grab from C3:F (last row). Second range is B19:F (last row). These two ranges overlap, so why not just copy B3:F (last row)?

Alternatively, you can try using this tool:
http://www.rondebruin.nl/win/addins/rdbmerge.htm

I know you've gotten pretty far already building your own code, but it might be worth a look just to see if it already does what your needed. Ron notes that his add-in can handle multiple ranges.