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.
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