How to pull data from a closed excel workbook and log into active workbook

[sdhutty]

Hello,

Before reading this bear in mind I'm an vba rookie!

I currently have an excel workbook called 'MasterRegister', within this workbook is a sheet called 'Register'.

I have another excel workbook called 'RO Status Log - Practice Copy', within this workbook is a sheet called 'R&O Closed'. This sheet is regularly updated with information in the format below: (NOTE: When it updates it adds a row to the top not the bottom)

Column A Column B Column C Column D Column E

R&O Number	Document Number	Document Type	Unit Affected	Issue/Revision
15610	J466	REPORT	ENGINE	1
17483	JRRU	LETTER	F18	8
78172	HGU7	SERVICE	2891	10

<tbody>
</tbody>

As this is updated with new data, I want the excel workbook 'MasterRegister' to also record this same new data in its worksheet "Register" WITHOUT needing to open the 'RO Status Log' workbook.

I want it to record the information in the columns stated below:

R&O Number: Column A
Document Number: Column B
Document Type: Column B
Unit Affected: Column L
Issue/Revision: Column G

So in procedure: I will open the 'MasterRegister' workbook & from a command button on the 'Register' sheet - it will show a message box stating:

"5 new entries have been made in RO Status Log - Entries now recorded in the sheet". If there isn't any new entries it will say "No new entries".

I have attempted to do this - but by pressing the command button it opens the RO Status log workbook which I obviously do not want and attempts to copy the whole column which I do not want also.

Sub AutoCopyVersion()
Dim pasteTo As Range
Dim countRows, i As Long
countRows = Application.CountA(Range("A:A"))
Workbooks.Open Filename:="C:\Users\SAN1011\Documents\RO Status Log - Practice Copy.xlsm"
i = Application.CountA(ActiveWorkbook.Sheets("R&O Closed").Range("A:A"))
If i = countRows Then Exit Sub
ActiveWorkbook.Sheets("R&O Closed").Range("A" & countRows + 1 & ":C" & i).Select
Selection.Copy
Workbooks("RO Status Log - Practice Copy.xlsm").Close
Set pasteTo = Sheets("Register").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
ThisWorkbook.ActiveSheet.Paste Destination:=pasteTo
Application.CutCopyMode = False
End Sub

 

[sdhutty]

Hi Baitmaster,

Yes all seems to be going well! I've tested it and the new updates seem to come into the spreadsheet as I wanted!

I changed the values you wanted as seen here:

' calculate new entries
iNewRecords = countRowsSource - countRowsThis - 3

and

' create address for copying
        strAddress = "A" & 4 & ":E" & iNewRecords + 3 ' allows +1 for header row

Few things which I was wondering to do:

1) Is there any way of hiding the source file spreadsheet so It doesn't show its opened to the user when the code runs?
2) When the message dialog box appears with the notification of:

"4 new records found at range A4:E7. Do you wish to import? ; R&O Folder Link; ;" - Is there anyway to change this notification to lets say:

"4 new records found. R&O Numbers: 15684,15861,15676,15898. Do you wish to import?"

Thanks

 

[baitmaster]

1) Try application.screenupdating = false at the start of the code, and then switch it back to true when you need to

2) the code I set up is supposed to be doing just that, subject to one or two changes to the text. This line:

For Each cl In Range(strAddress).Columns(1).cells

is going through each cell in the first column of your new data, the values are then passed to an array. According to post 1, this column contains these reference numbers. This code

Join(arrResults, "; ")

turns those values into a text string. We could set the delimiter to comma instead of semi-colon by changing this

Your end result would therefore be

proceed = MsgBox(iNewRecords & " new records found. R&O numbers " & Join(arrResults, ", ") & ". Do you wish to import?", vbQuestion + vbYesNo)

Except I don't understand why you're getting the wrong values being loaded into the array. Where do the text item "R&O Folder Link" and the other blank values come from?

 

[sdhutty]

Here is the latest code in full:

Sub AutoCopyVersion()
Dim countRowsThis As Long, countRowsSource As Long, iNewRecords As Integer, strAddress As String, strReport As String, intBtnType As Integer, proceed As Integer
Dim arrResults(), i As Integer, cl As Range

' count rows in this file
countRowsThis = Application.CountA(Range("A:A"))

' open source file, which becomes active file
Application.ScreenUpdating = False
Workbooks.Open Filename:="C:\Users\SAN1011\Documents\RO Status Log - Practice Copy.xlsm"

' count rows in that source file
countRowsSource = Application.CountA(ActiveWorkbook.Sheets("R&O Closed").Range("A:A"))

' calculate new entries
iNewRecords = countRowsSource - countRowsThis - 3

' decide what to do based on delta
Select Case iNewRecords
    Case Is < 0
        strReport = "ERROR: there are less entries in source file than in this file. Row(s) have been deleted from the source file. Please amend."
        intBtnType = vbCritical
        
    Case 0
        strReport = "No new entries found."
        intBtnType = vbInformation
        
    Case Else
        
        ' create address for copying
        strAddress = "A" & 4 & ":E" & iNewRecords + 3 ' allows +1 for header row
        
        ' resize array to hold references
        ReDim arrResults(1 To iNewRecords)
        For Each cl In Range(strAddress).Columns(1).Cells
            i = i + 1
            arrResults(i) = cl.Value
        Next cl
        
        ' ask if import required
        Debug.Print Join(arrResults, ", ")
        proceed = MsgBox(iNewRecords & " new records found. R&O Numbers: " & Join(arrResults, ", ") & ". Do you wish to import?", vbQuestion + vbYesNo)
        If proceed = vbYes Then
        
            ' copy / paste
            With ActiveWorkbook.Sheets("R&O Closed").Range(strAddress)
                .Columns(1).Copy
                ThisWorkbook.Sheets("Register").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(2).Copy
                ThisWorkbook.Sheets("Register").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(3).Copy
                ThisWorkbook.Sheets("Register").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(4).Copy
                ThisWorkbook.Sheets("Register").Range("L" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(5).Copy
                ThisWorkbook.Sheets("Register").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
            
            Application.CutCopyMode = False
            
            strReport = iNewRecords & " new entries found. Copied from range " & strAddress
            intBtnType = vbInformation
        Else
            ' no action required
        End If
        
End Select
' report results and close file
endRoutine:
Workbooks("RO Status Log - Practice Copy.xlsm").Close savechanges:=False
If strReport <> "" Then MsgBox strReport, intBtnType
End Sub

1) I have put the 'Application.ScreenUpdating = False' at the start and ran the code & seems to work, thanks

2) I have changed to a comma and ran the code. the code now says:

"4 new records found. R&O Numbers:, R&O Folder Link, gggg, . Do you wish to import?"

I am not sure where "R&O Folder Link" is coming from as it is not in the code anywhere. LOL

 

[sdhutty]

Hi the 'R&O Folder Link' is coming from the table header.

& 'gggg' is coming from row 6 column A. But even when I remove this 'gggg' and run the code, it now says:

"5 new records. R&O Numbers: , R&O Folder Link, , , . Do you wish to import?"

 

[baitmaster]

According to your original requirement, column A should contain references, not blanks. Currently it looks like there's just blanks there

I've made a few tweaks to how we identify the number of records in each file, which failed to consider blank rows in the headers, and then how we apply these values

Option Explicit

Sub AutoCopyVersion()
Dim countRowsThis As Long, countRowsSource As Long, iNewRecords As Integer, strAddress As String, strReport As String, intBtnType As Integer, proceed As Integer
Dim arrResults(), i As Integer, cl As Range

[COLOR=#FF0000]' constants = # of headers in each file - amend as necessary
Const iHeaderRowsThis As Integer = 1
Const iHeaderRowsSource As Integer = 3[/COLOR]

[COLOR=#FF0000]' get last row and count rows in this file
countRowsThis = Range("A1084576").End(xlUp).Row - iHeaderRowsThis[/COLOR]

' open source file, which becomes active file
Application.ScreenUpdating = False
Workbooks.Open Filename:="C:\Users\SAN1011\Documents\RO Status Log - Practice Copy.xlsm"

[COLOR=#FF0000]' get last row and count rows in that source file
countRowsSource = ActiveWorkbook.Sheets("R&O Closed").Range("A1084576").End(xlUp).Row - iHeaderRowsSource[/COLOR]

' calculate new entries
[COLOR=#FF0000]iNewRecords = countRowsSource - countRowsThis[/COLOR]

' decide what to do based on delta
Select Case iNewRecords
    Case Is < 0
        strReport = "ERROR: there are less entries in source file than in this file. Row(s) have been deleted from the source file. Please amend."
        intBtnType = vbCritical
        
    Case 0
        strReport = "No new entries found."
        intBtnType = vbInformation
        
    Case Else
        
        ' create address for copying
        [COLOR=#FF0000]strAddress = "A" & iHeaderRowsSource + 1 & ":E" & iNewRecords + iHeaderRowsSource[/COLOR]
        
        ' resize array to hold references
        ReDim arrResults(1 To iNewRecords)
        For Each cl In Range(strAddress).Columns(1).Cells
            i = i + 1
            arrResults(i) = cl.Value
        Next cl
        
        ' ask if import required
        Debug.Print Join(arrResults, ", ")
        proceed = MsgBox(iNewRecords & " new records found. R&O Numbers: " & Join(arrResults, ", ") & ". Do you wish to import?", vbQuestion + vbYesNo)
        If proceed = vbYes Then
        
            ' copy / paste
            With ActiveWorkbook.Sheets("R&O Closed").Range(strAddress)
                .Columns(1).Copy
                ThisWorkbook.Sheets("Register").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(2).Copy
                ThisWorkbook.Sheets("Register").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(3).Copy
                ThisWorkbook.Sheets("Register").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(4).Copy
                ThisWorkbook.Sheets("Register").Range("L" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                .Columns(5).Copy
                ThisWorkbook.Sheets("Register").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End With
            
            Application.CutCopyMode = False
            
            strReport = iNewRecords & " new entries found. Copied from range " & strAddress
            intBtnType = vbInformation
        Else
            ' no action required
        End If
        
End Select

' report results and close file
endRoutine:
Workbooks("RO Status Log - Practice Copy.xlsm").Close savechanges:=False
If strReport <> "" Then MsgBox strReport, intBtnType
End Sub

 

[sdhutty]

I run that code and get:

"Run-time error '1004': Application-defined or object-defined error" - I changed the range back to ("A:A") from the range you put in and still get the same error.

The latest code which I posted was working fine. It updated accordingly however when I put information into the column A of register worksheet and filled upto the next blank row and ran the code again, its now stating the "ERROR less entries in source file than this file."

I thought that it runs and puts it into the next blank row anyway?

Column A contains references maybe in the R0 Status Log you're on about?

In the Register worksheet column A is filled up to the last blank row.

 

[baitmaster]

which line of code is breaking?

 

[baitmaster]

Typo. The last cell in column 1 is A1048576

 

[sdhutty]

I'm not entirely sure what the new code you provided to me is doing, could you explain further please, why have you programmed it to read the last cell?


If it makes any more help, the 'RO Status Log' as you know begins its data on row 4.

The register worksheet begins its data on row 6. There is already data filled from row 6 to row 1257, making the next blank row at 1258. (Column A is filled between those rows - just clear that up for you).

Now with the latest code I posted, the code doesn't break. It still runs however for some reason doesn't pick up the data as we once got it to do and just skips to the message of "ERROR: less source files etc".

Maybe there is some miscalculation with the headers I am missing?

 

[baitmaster]

I'm trying to compare the size of two data sets to see how many new items there are. I can't see these so I'm looking for clear guidance from you as to their sizes, and I've told you I'm assuming there are a set number of headers in each file, and no data afterwards. You can change the header row count in the code by amending the 2 constants I've created. The end of the dataset is found by starting at the very end of the worksheet (cell A1048576) and jumping up to the next cell found with data in it. It's the code equivalent of holding CTRL and hitting a directional arrow. This is why the data must have nothing underneath it, else the code will produce the wrong answer

So I'm calculating the sizes of the 2 datasets as follows:
End of dataset = start at very end cell, use CTRL + arrow to jump up to last cell, and identify row
Start of dataset = based on constants iHeaderRowsThis and iHeaderRowsSource
Size of dataset = End row less headers row

Difference between Source dataset size and This dataset size = number of records to be imported