Macro to activate two particular worksheets based on sheet name in multiple open workbooks

[patsdavixen]

Hi,

If I have multiple workbooks open and I want to copy data from only workbook based on the sheet name to another workbook again based on the sheet name, is that possible? The workbook names are variable.

For example, if I had 5 workbooks open with file names A,B,C,D,E.
In workbook B, there is a sheet entitled "Old" and in workbook E, there is a sheet entitled "New".
Can a macro find the sheet entitled "Old" in workbook B, copy all data and find workbook E again and paste the data in the sheet entitled "New"?

Currently I have written my entire macro around the limitation that the user needs to close all excel workbooks excluding workbook B & E.
I have simply used ActiveWindow.ActivateNext to get the job done. The other limitation is that the user needs to begin the macro on the workbook entitled B.

Any suggestions will be appreciated as I really need to complete this marco soon.

Thank you.

 

[Jerry Sullivan]

Hi patsdavixen,

Yes, you can reference an open workbook by its file name (without the path).
In fact the code is more efficient if you don't go back and forth activating workbooks and sheets but instead just reference them with fully qualified names.

Sub CopyBtwnWorkbooks()
      
    With Workbooks("B.xlsm").Sheets("Old")
        .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
    End With
    Workbooks("E.xlsx").Sheets("New").Range("A1").PasteSpecial (xlPasteValues)
   
End Sub

 

[patsdavixen]

Hi Jerry,

Thank you for replying to my post.
The thing is that the workbook names are variable.. only the worksheet names are constant.
Do you know of a way to have a macro activate two seperate workbooks by finding a sheet name in one that matches "Old" and again finding a sheet name in the other that matches "New"?

 

[Jerry Sullivan]

Pat, That could work if your sure you won't have two files open with one of these sheet names, or the wrong workbook open with one of those sheetnames.

Below is some code you could try. Copy the Sub and two Function procedures into the same Code Module.

Sub CopyBtwnWorkbooks()
    Dim wsOld As Worksheet, wsNew As Worksheet

    
    Set wsOld = FindSheetInOpenWorkbooks("Old")
    Set wsNew = FindSheetInOpenWorkbooks("New")
    If wsOld Is Nothing Or wsNew Is Nothing Then
        MsgBox "Sheets with matching names not found in open workbooks"
        Exit Sub
    End If

    
    With wsOld
        .Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
    End With
    wsNew.Range("A1").PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
End Sub

Private Function FindSheetInOpenWorkbooks(sSheetName As String) As Worksheet
'--returns reference to first instance of worksheet with name in WorkBooks collection.
'  -- if no match found returns Nothing
    Dim wb As Workbook

    
    For Each wb In Workbooks
        If WorksheetExists(sSheetName, wb) Then
            Set FindSheetInOpenWorkbooks = wb.Worksheets(sSheetName)
            Exit Function
        End If
    Next wb
End Function

Private Function WorksheetExists(sName As String, wb As Workbook) As Boolean
'--returns True if worksheet exists in wb, else returns False
    On Error Resume Next
    WorksheetExists = wb.Worksheets(sName).Index > 0
End Function

 

[patsdavixen]

Jerry, once again your code worked perfectly!!!
You are an excel/vba genius
Thank you so much

 

[amprice09]

Jerry - I believe this code is EXACTLY what I need. I'm trying to incorporate it in my my Macro which takes two open workbooks with varying names and does a vlookup from one sheet to another. Currently I have to hard code a template and reference it in the code. But, in trying to apply this logic / code, I keep hitting snags.

First - My macro doesn't like me placing Private functions in it. Where do I put your Sub and Private Functions where it won't error out?
Second - How do I refer to each workbook as it is defined by the Set commands?

Some sample of my current code:

Sub CopyBtwnWorkbooks()
Dim BOMR As Worksheet

Set BOMR = FindSheetInOpenWorkbooks("BOMR")
End Sub

Private Function FindSheetInOpenWorkbooks(sSheetName As String) As Worksheet
'--returns reference to first instance of worksheet with name in WorkBooks collection.
' -- if no match found returns Nothing
Dim wb As Workbook


For Each wb In Workbooks
If WorksheetExists(sSheetName, wb) Then
Set FindSheetInOpenWorkbooks = wb.Worksheets(sSheetName)
Exit Function
End If
Next wb
End Function
Private Function WorksheetExists(sName As String, wb As Workbook) As Boolean
'--returns True if worksheet exists in wb, else returns False
On Error Resume Next
WorksheetExists = wb.Worksheets(sName).Index > 0
End Function

Sub Report()
'
' Report Macro
'
' Keyboard Shortcut: Ctrl+Shift+R
'
'Testing for name to not matter below

'This is where I was trying to put the code

'Testing for name to not matter above

Range("A1:I1").Select
.... Further down...

'Below was added to Refresh Pivot in BOMR Tab
With BOMR.Range
' Windows("Reports Template.xlsx").Activate <-- Hard coded to call template
' Windows(wb.Worksheets(BOMR)).Activate
Sheets("BOMR").Select
Range("l:q").Select

... Further Down where I have my hard coded Vlookup formula currently...

Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-9]="""",(IFERROR(VLOOKUP(RC[-10],'[Reports Template.xlsx]BOMR'!R1C38:R5000C39,2,0),"""")),RC[-9])"
Selection.AutoFill Destination:=Range("K2:K32"), Type:=xlFillDefault

Range("K2:K32").Select

Is this enough information? Any ideas? Thanks!
Aaron

 

[amprice09]

Jerry - Okay I think I figured it out... BUT... Now I just need to reference my wsold in my vlookup formula... Hmmmmm

 

[Jerry Sullivan]

Hi Aaron,

If you'll post your entire code for your latest version of Sub Report, I'll help with the formula.

 

[amprice09]

Jerry - I am good I believe now except my VLOOKUP formula at the bottom.

Sub CopyBtwnWorkbooks()
'
' FixPercentage2 Macro
'
' Keyboard Shortcut: Ctrl+k
Dim wsOld As Worksheet, wsNew As Worksheet


Set wsOld = FindSheetInOpenWorkbooks("Old")
Set wsNew = FindSheetInOpenWorkbooks("Sheet1")
If wsOld Is Nothing Or wsNew Is Nothing Then
MsgBox "Sheets with matching names not found in open workbooks"
Exit Sub
End If
With wsOld
.Range("A1:AB" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
End With
wsNew.Range("A1").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Range("A1:I1").Select
' Make Row Center
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.RowHeight = 15
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' Make Row Center Above
Range("I1").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("K1:L1").Select
Range("L1").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("L1").Select
ActiveCell.FormulaR1C1 = "Comp Less Mgmt"
Range("L2:L21").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("I2:I23").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B2:H20").Select
Range("H20").Activate
Selection.NumberFormat = "$#,##0"

Sheets("Major Suppliers").Select
'Below was added to Refresh Pivot in BOMR Tab
' With BOMR.Range
' wb.Sheets("BOMR").Activate
' Windows("Reports Template.xlsx").Activate
With wsOld



' Windows(wb.Worksheets(BOMR)).Activate
wsOld.Activate

Range("l:q").Select
Range("l1").Activate
Selection.NumberFormat = "$#,##0.00"
Range("i:i").Select
Range("i1").Activate
Selection.NumberFormat = "0%"
ActiveWorkbook.RefreshAll
End With

Windows("Report 24 - Material Summary Report for").Activate

'Above was added to Refresh Pivot in BOMR Tab
'Below was added for descriptions
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-9]="""",(IFERROR(VLOOKUP(RC[-10],'Sheet1'!R1C38:R5000C39,2,0),"""")),RC[-9])"
Selection.AutoFill Destination:=Range("K2:K32"), Type:=xlFillDefault

 

[Jerry Sullivan]

Aaron, The code below shows one way to build the formula to be entered in Range(K2:K32).

The macro recorder generates a lot of Select, Activate and Selection statements that track your manual steps.
When writing code, it's rarely necessary to Select or Activate objects. It's more efficient to reference the objects without Selecting them.

More importantly, it's harder to understand code that uses Select, Activate, Selection statements. I've tried to interpret your code and convert it to direct referencing of object; however it wouldn't surprise me if I've misunderstood which range or workbook was selected some steps. Please check that over and correct where needed.

Sub CopyBtwnWorkbooks()
 '
 ' FixPercentage2 Macro
 '
 ' Keyboard Shortcut: Ctrl+k

 Dim sTableArrayRef As String
 Dim wsOld As Worksheet, wsNew As Worksheet

 Set wsOld = FindSheetInOpenWorkbooks("Old")
 Set wsNew = FindSheetInOpenWorkbooks("Sheet1")
 
 If wsOld Is Nothing Or wsNew Is Nothing Then
   MsgBox "Sheets with matching names not found in open workbooks"
   Exit Sub
 End If
 
 With wsOld
   .Range("A1:AB" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
 End With
 
 With wsNew
   .Range("A1").PasteSpecial (xlPasteValues)
   '--apply center formatting to header row and data body columns
   With .Range("1:1,L2:L21,I2:I23")
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlBottom
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
      .RowHeight = 15
   End With
 End With
 With wsNew
   '--apply color to header row
   With .Range("1:1").Interior
      .Pattern = xlSolid
      .PatternColorIndex = xlAutomatic
      .ThemeColor = xlThemeColorDark1
      .TintAndShade = -0.249977111117893
      .PatternTintAndShade = 0
   End With
   '--apply number format to specified data fields
   .Range("B2:H20").NumberFormat = "$#,##0"
   '--rename one field in header
   .Range("L1").Value = "Comp Less Mgmt"
 End With
 
 With wsOld
   '--apply numberformats
   .Range("l:q").NumberFormat = "$#,##0.00"
   .Range("i:i").NumberFormat = "0%"
   '--refreshall in workbook that has wsOld (BOMR Tab)
   .Parent.RefreshAll
 End With

 '--get a reference to lookup table range in the old workbook for vlookup formula
 '  reading address property with external:=true returns full range reference
 '    including the workbook name for example:
 '    "'[Reports Template.xlsx]BOMR'!R1C38:R5000C39"
 
 sTableArrayRef = wsOld.Range("AL1:AM5000").Address( _
   RowAbsolute:=True, ColumnAbsolute:=True, _
   ReferenceStyle:=xlR1C1, External:=True)
 
 '--Add formulas for descriptions
 With wsNew.Range("K2:K32")
   .FormulaR1C1 = "=IF(RC[-9]="""",IFERROR(VLOOKUP(RC[-10]," & _
      sTableArrayRef & ",2,0),""""),RC[-9])"
 End With

 End Sub