Excel VBA to remember current open workbooks

B

Bagsy

Active Member
Joined
Feb 26, 2005
Messages
467
Office Version
  1. 365
Platform
  1. Windows
Can somebody please advise on this?
I have some code which opens seven excel registers from a list, searches and copies some information onto my current workbook. This is all working fine.
I would generally have perhaps three or four of these registers open whilst I am working, amongst other excel workbooks. I can set my code to either run and close all seven registers from the list (which means I need to be sure that these are all saved, then re-open them), or run and leave all seven open (and close them down manually)
What I would like to know is there a way that I can change my code so it remembers which of these registers that I already had open and just close the ones I’m not working on.
All help is appreciated.
VBA Code: 
Code below
Sub CopyFromAllRegisters()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim I As Integer
Dim c As Integer
Dim directory As String
Dim filename As String
Dim ws As Worksheet
Dim wb As ThisWorkbook
Dim wbk As Workbook
Dim a As String
'Dim ans As Integer
'    ans = MsgBox("WARNING!" & vbCrLf & "THIS WILL CLOSE ALL OPEN REGISTERS, ENSURE ALL ARE SAVED" & vbCrLf & "Press Cancel to Exit", vbOKCancel)
'        Select Case ans
'            Case vbOK

Set wb = ActiveWorkbook
Set ws = ThisWorkbook.Worksheets("Cert Data")

Call DeletePhosphateCerts 'this is removing the phosphate certs

    Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"


'define location of material registers
directory = "L:\MATERIALS\Material Certification\"

'-----------------------------------------------------------------code to open each material register in turn
For I = 2 To Cells(Rows.Count, "N").End(xlUp).Row 'N is the column name  where the filenames are stored

   'define filename of material registers
   filename = Dir(directory & ws.Range("N" & I).Value & ".xlsm")
   
   If filename <> "" Then 'check if material register does not exist
      Set wbk = Workbooks.Open(directory & filename, ReadOnly:=True) 'open material register
      
      '-----------------------------------------------------------------Need to add my code here
wb.Activate
Worksheets("Cert Data").Select
'    Columns("A:A").Select
'    Selection.NumberFormat = "@"
    
Range("A1").Select
Range("A1", Range("A1").End(xlDown)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes 'sorting the numbers in order to match the order the excel material registers

       For c = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'counting the cert numbers we need to search for
    a = ws.Cells(c, 1).Value


wbk.Activate
    For J = 2 To wbk.Worksheets(1).Cells(ws.Rows.Count, 1).End(xlUp).Row
        If wbk.Worksheets(1).Cells(J, 1).Value = a Then                 'If cert number (Row 1) in column A on the first sheet on the Material registers
                                                                        '= the cert number(Value a)in column 1 in worksheet "Cert Data" in the active workbook
                                                                        'then copy cells 2 thru to 10, from the Material register to the Cert Data sheet on active workbook
                                                                        'then continue search every row to look for more matches
                                                                        'then repeat on each workbook as it is opened.
                                                                        
                 wbk.Worksheets(1).Cells(J, 2).Copy
                 wb.Sheets("Cert Data").Cells(c, 2).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 3).Copy
                 wb.Sheets("Cert Data").Cells(c, 3).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 4).Copy
                 wb.Sheets("Cert Data").Cells(c, 4).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 5).Copy
                 wb.Sheets("Cert Data").Cells(c, 5).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 6).Copy
                 wb.Sheets("Cert Data").Cells(c, 6).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 7).Copy
                 wb.Sheets("Cert Data").Cells(c, 7).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 8).Copy
                 wb.Sheets("Cert Data").Cells(c, 8).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 9).Copy
                 wb.Sheets("Cert Data").Cells(c, 9).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 10).Copy
                 wb.Sheets("Cert Data").Cells(c, 10).PasteSpecial Paste:=xlPasteValues

End If


    Next J

 Next c
        
      ''-----------------------------------------------------------------to here
   End If
   
   'wbk.Close (False)
Next I 'loop ends here and it will continue to last material register as it works down the list
ThisWorkbook.Activate
Sheets("Cert Data").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Case vbCancel
'End Select
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
try this code ( untested)
VBA Code: 
Dim wb As Workbook
  
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb
  Next kk
 
Upvote 0
offthelip said:
try this code ( untested)
VBA Code: 
Dim wb As Workbook
 
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb
  Next kk
Click to expand...
Thanks for helping
I have added your code to mine, but not sure if I have got it right. I tried to run it but got an "object variable with block variable not set" at this line wb.Activate
Please see full code below

VBA Code: 
Sub CopyFromAllRegisters2()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim I As Integer
Dim c As Integer

Dim directory As String
Dim filename As String
Dim ws As Worksheet
'Dim wb As ThisWorkbook
Dim wb As Workbook
Dim a As String
'Dim ans As Integer
'    ans = MsgBox("WARNING!" & vbCrLf & "THIS WILL CLOSE ALL OPEN REGISTERS, ENSURE ALL ARE SAVED" & vbCrLf & "DELETE ALL PHOSPHATE CERTS" & vbCrLf & "Press Cancel to Exit", vbOKCancel)
'        Select Case ans
'            Case vbOK

Set wb = ActiveWorkbook
Set ws = ThisWorkbook.Worksheets("Cert Data")

Call DeletePhosphateCerts 'this is removing the phosphate certs

   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb
  Next kk

'define location of material registers
directory = "L:\MATERIALS\Material Certification\"

'-----------------------------------------------------------------code to open each material register in turn
For I = 2 To Cells(Rows.Count, "N").End(xlUp).Row 'N is the column name  where the filenames are stored

   'define filename of material registers
   filename = Dir(directory & ws.Range("N" & I).Value & ".xlsm")
   
   If filename <> "" Then 'check if material register does not exist
      Set wbk = Workbooks.Open(directory & filename, ReadOnly:=True) 'open material register
      
wb.Activate
Worksheets("Cert Data").Select

'    Columns("A:A").Select
'    Selection.NumberFormat = "@"
    
Range("A1").Select
Range("A1", Range("A1").End(xlDown)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes 'sorting the numbers in order to match the order the excel material registers

       For c = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'counting the cert numbers we need to search for
    a = ws.Cells(c, 1).Value


wbk.Activate
    For J = 2 To wbk.Worksheets(1).Cells(ws.Rows.Count, 1).End(xlUp).Row
        If wbk.Worksheets(1).Cells(J, 1).Value = a Then                 'If cert number (Row 1) in column A on the first sheet on the Material registers
                                                                        '= the cert number(Value a)in column 1 in worksheet "Cert Data" in the active workbook
                                                                        'then copy cells 2 thru to 10, from the Material register to the Cert Data sheet on active workbook
                                                                        'then continue search every row to look for more matches
                                                                        'then repeat on each workbook as it is opened.
                                                                        
                 wbk.Worksheets(1).Cells(J, 2).Copy
                 wb.Sheets("Cert Data").Cells(c, 2).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 3).Copy
                 wb.Sheets("Cert Data").Cells(c, 3).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 4).Copy
                 wb.Sheets("Cert Data").Cells(c, 4).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 5).Copy
                 wb.Sheets("Cert Data").Cells(c, 5).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 6).Copy
                 wb.Sheets("Cert Data").Cells(c, 6).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 7).Copy
                 wb.Sheets("Cert Data").Cells(c, 7).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 8).Copy
                 wb.Sheets("Cert Data").Cells(c, 8).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 9).Copy
                 wb.Sheets("Cert Data").Cells(c, 9).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 10).Copy
                 wb.Sheets("Cert Data").Cells(c, 10).PasteSpecial Paste:=xlPasteValues

End If

    Next J

 Next c
        
   End If
   
   'wbk.Close (False)
Next I 'loop ends here and it will continue to last material register as it works down the list
ThisWorkbook.Activate
Sheets("Cert Data").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Case vbCancel
'End Select

  For kk = 1 To UBound(inarr, 1)
   For Each wb In Application.Workbooks
     If wb.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb
  Next kk
End Sub
 
Upvote 0
I think your problem is probably because I used the wb as a variable in my code and you used the same variable in your code, my mistake sorry!!
so use this code instead:
VBA Code: 
Dim wb2close As Workbook
  
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb2close
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb2close
  Next kk
End Sub
 
Upvote 0
offthelip said:
I think your problem is probably because I used the wb as a variable in my code and you used the same variable in your code, my mistake sorry!!
so use this code instead:
VBA Code: 
Dim wb2close As Workbook
 
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb2close
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb2close
  Next kk
End Sub
Click to expand...
Your time helping is very much appreciated.
I added your amended code which ran just fine but still left all the excel workbooks open
Please see code below
VBA Code: 
Sub CopyFromAllRegisters2()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim I As Integer
Dim c As Integer

Dim directory As String
Dim filename As String
Dim ws As Worksheet
Dim wb As ThisWorkbook
Dim a As String
'Dim ans As Integer
'    ans = MsgBox("WARNING!" & vbCrLf & "THIS WILL CLOSE ALL OPEN REGISTERS, ENSURE ALL ARE SAVED" & vbCrLf & "DELETE ALL PHOSPHATE CERTS" & vbCrLf & "Press Cancel to Exit", vbOKCancel)
'        Select Case ans
'            Case vbOK

Set wb = ActiveWorkbook
Set ws = ThisWorkbook.Worksheets("Cert Data")

Call DeletePhosphateCerts 'this is removing the phosphate certs

Dim wb2close As Workbook
  
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = False
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
       inarr(kk, 2) = True
       Exit For
     End If
   Next wb2close
  Next kk

'define location of material registers
directory = "L:\MATERIALS\Material Certification\"

'-----------------------------------------------------------------code to open each material register in turn
For I = 2 To Cells(Rows.Count, "N").End(xlUp).Row 'N is the column name  where the filenames are stored

   'define filename of material registers
   filename = Dir(directory & ws.Range("N" & I).Value & ".xlsm")
   
   If filename <> "" Then 'check if material register does not exist
      Set wbk = Workbooks.Open(directory & filename, ReadOnly:=True) 'open material register
      
wb.Activate
Worksheets("Cert Data").Select

'    Columns("A:A").Select
'    Selection.NumberFormat = "@"
    
Range("A1").Select
Range("A1", Range("A1").End(xlDown)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes 'sorting the numbers in order to match the order the excel material registers

       For c = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'counting the cert numbers we need to search for
    a = ws.Cells(c, 1).Value


wbk.Activate
    For J = 2 To wbk.Worksheets(1).Cells(ws.Rows.Count, 1).End(xlUp).Row
        If wbk.Worksheets(1).Cells(J, 1).Value = a Then                 'If cert number (Row 1) in column A on the first sheet on the Material registers
                                                                        '= the cert number(Value a)in column 1 in worksheet "Cert Data" in the active workbook
                                                                        'then copy cells 2 thru to 10, from the Material register to the Cert Data sheet on active workbook
                                                                        'then continue search every row to look for more matches
                                                                        'then repeat on each workbook as it is opened.
                                                                        
                 wbk.Worksheets(1).Cells(J, 2).Copy
                 wb.Sheets("Cert Data").Cells(c, 2).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 3).Copy
                 wb.Sheets("Cert Data").Cells(c, 3).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 4).Copy
                 wb.Sheets("Cert Data").Cells(c, 4).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 5).Copy
                 wb.Sheets("Cert Data").Cells(c, 5).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 6).Copy
                 wb.Sheets("Cert Data").Cells(c, 6).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 7).Copy
                 wb.Sheets("Cert Data").Cells(c, 7).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 8).Copy
                 wb.Sheets("Cert Data").Cells(c, 8).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 9).Copy
                 wb.Sheets("Cert Data").Cells(c, 9).PasteSpecial Paste:=xlPasteValues
                 wbk.Worksheets(1).Cells(J, 10).Copy
                 wb.Sheets("Cert Data").Cells(c, 10).PasteSpecial Paste:=xlPasteValues

End If

    Next J

 Next c
        
   End If
   
   'wbk.Close (False)
Next I 'loop ends here and it will continue to last material register as it works down the list
ThisWorkbook.Activate
Sheets("Cert Data").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Case vbCancel
'End Select

  For kk = 1 To UBound(inarr, 1)
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) Then
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb2close
  Next kk
End Sub
 
Upvote 0
I said it was untested!! I forgot the xlsm!!
try this:
VBA Code: 
Dim wb2close As Workbook
 
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = True                                              ' note this change
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) & ".xlsm" Then   ' note this change
       inarr(kk, 2) = False                                             ' note this change
       Exit For
     End If
   Next wb2close
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) & ".xlsm" Then    ' note this change
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb2close
  Next kk
End Sub
I just realised I had got the logic round the wrong way too
 
Upvote 0
Solution
offthelip said:
I said it was untested!! I forgot the xlsm!!
try this:
VBA Code: 
Dim wb2close As Workbook
 
   Range("N2") = "Material Receipt & Traceability Register 01 Pipe"
        Range("N3") = "Material Receipt & Traceability Register 02 Section"
            Range("N4") = "Material Receipt & Traceability Register 03 Plate"
                Range("N5") = "Material Receipt & Traceability Register 04 Fittings"
            Range("N6") = "Material Receipt & Traceability Register 05 Electrodes"
        Range("N7") = "Material Receipt & Traceability Register 06 HT & Testing"
    Range("N8") = "Material Receipt & Traceability Register 07 Paint & Coating"
 inarr = Range("N2:O8") ' define 2 dimensional array of these workbooks


  For kk = 1 To UBound(inarr, 1)
   inarr(kk, 2) = True                                              ' note this change
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) & ".xlsm" Then   ' note this change
       inarr(kk, 2) = False                                             ' note this change
       Exit For
     End If
   Next wb2close
  Next kk
 
  '' all the rest of your code
 
  For kk = 1 To UBound(inarr, 1)
   For Each wb2close In Application.Workbooks
     If wb2close.Name = inarr(kk, 1) & ".xlsm" Then    ' note this change
      If inarr(kk, 2) Then
       Workbooks(inarr(kk, 1)).Close SaveChanges:=False
      End If
      Exit For
     End If
   Next wb2close
  Next kk
End Sub
I just realised I had got the logic round the wrong way too
Click to expand...
Thanks for that, it made a difference but it closes down the workbooks I had open and left the workbooks I didn't already have open. Will it be possible to just change it again to do the opposite, that would be fantastic
 
Upvote 0
Bagsy said:
Thanks for that, it made a difference but it closes down the workbooks I had open and left the workbooks I didn't already have open. Will it be possible to just change it again to do the opposite, that would be fantastic
Click to expand...
Thank you so much, absolutely perfect
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Simplify my working code please
Replies
7
Views
166
ipbr21054
I
D
  • Solved
Need help creating a formula based on VBA function!
Replies
5
Views
346
Trixterz
T
I
  • Question Question
Value not shown in ComboBox1 when code run
Replies
1
Views
54
ipbr21054
I
C
  • Solved
Copy paste columns based on matching header into another workbook
Replies
5
Views
220
mumps
mumps
W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
198
who am i
W

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top