B
BJthebear
I am importing information to the destination workbook.
from a series of source workbooks all located in the same directory
using a macro
In order to prevent duplicate entries I wondered if when you close the
source Workbook you could transfer it/move it to an archive
subdirectory or if that is not possible - write a routine to check if
that information has already been imported and if so ignore that
particular workbook but I would like to have a check that information
has not already been imported from any specific workbook.
I think the first option would be better ie archive but I am not sure
how to write the VBA code.
Can anyone help
The code that I am starting with is as follows:-
Sub RetrieveData()
Dim sourceWB As Workbook
Dim sourceWS As Worksheet
Dim sourceBaseCell As Range
Dim destWS As Worksheet
Dim destBaseCell As Range
Dim RLC As Long ' row loop counter
Dim CLC As Long ' column loop counter
Dim sourceFileName As String
Dim sourcePath As String
'set up a reference to the destination sheet in
'this workbook
Set destWS = ThisWorkbook.Worksheets("Sheet1")
'find out the path from this file's path info
'get the entire name
sourcePath = ThisWorkbook.FullName
'remove the filename, leaving just the path to it
'assumes it is in same directory with needed files
sourcePath = Left(sourcePath, _
InStrRev(sourcePath, Application.PathSeparator))
'kickstart things
sourceFileName = Dir$(sourcePath & "*.xls")
'don't do this if we found our own name
'Dir$() returns empty string after last file match
'is found
Do Until sourceFileName = ""
'double-check that it's an Excel file and
'that it is not a reference to this workbook
If sourceFileName <> ThisWorkbook.Name And _
UCase(Right(sourceFileName, 4)) = ".XLS" Then
'open that workbook without nagging about
'things like updating links and open it as
'read only
Application.DisplayAlerts = False
'keep from blinking the screen too much
Application.ScreenUpdating = False
Workbooks.Open sourcePath & sourceFileName, 0, True
'we may need/want to see alerts now, so
Application.DisplayAlerts = True
'the workbook becomes the active workbook when it
'is opened
Set sourceWB = ActiveWorkbook
'set a reference to the sheet we need
'for this example, the sheet's name is "Entry Sheet"
'and the data we want starts at A9 and continues down
'for an unknown number of rows, and we need to pick
'up data from columns A through H
Set sourceWS = sourceWB.Worksheets("Entry Sheet")
Set sourceBaseCell = sourceWS.Range("A9")
'find out where to start putting new data on
'the destination sheet in this workbook
'first, lets make this workbook the active one
ThisWorkbook.Activate
Set destBaseCell = _
destWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
'run down the rows in the source sheet until we hit
'an empty cell
RLC = 0 ' initialize/reset
Do While Not IsEmpty(sourceBaseCell)
'transfer data into this workbook
For CLC = 0 To 7 ' column A through H as offset from A
destBaseCell.Offset(RLC, CLC) = _
sourceBaseCell.Offset(0, CLC)
Next ' next column
'get new sourceBaseCell location
Set sourceBaseCell = sourceBaseCell.Offset(1, 0)
'update row pointer for this workbook's sheet
RLC = RLC + 1
Loop
'have hit empty cell in source book, done with it
'close without saving any changes
'do some housekeeping along the way
Set sourceBaseCell = Nothing
Set sourceWS = Nothing
sourceWB.Close False
Set sourceWB = Nothing
End If
Application.ScreenUpdating = True ' show results
'you could save sourceFileName somewhere at this
'point so you could later test to see if you have
'previously read data from it - that code, and
'the test to see if it's been read before is NOT
'included in this example
'
'get next possible filename
sourceFileName = Dir$()
Loop
'we are all done now
'do final housekeeping
Set destBaseCell = Nothing
Set destWS = Nothing
MsgBox "Data Retrieval Has Been Completed"
End Sub
from a series of source workbooks all located in the same directory
using a macro
In order to prevent duplicate entries I wondered if when you close the
source Workbook you could transfer it/move it to an archive
subdirectory or if that is not possible - write a routine to check if
that information has already been imported and if so ignore that
particular workbook but I would like to have a check that information
has not already been imported from any specific workbook.
I think the first option would be better ie archive but I am not sure
how to write the VBA code.
Can anyone help
The code that I am starting with is as follows:-
Sub RetrieveData()
Dim sourceWB As Workbook
Dim sourceWS As Worksheet
Dim sourceBaseCell As Range
Dim destWS As Worksheet
Dim destBaseCell As Range
Dim RLC As Long ' row loop counter
Dim CLC As Long ' column loop counter
Dim sourceFileName As String
Dim sourcePath As String
'set up a reference to the destination sheet in
'this workbook
Set destWS = ThisWorkbook.Worksheets("Sheet1")
'find out the path from this file's path info
'get the entire name
sourcePath = ThisWorkbook.FullName
'remove the filename, leaving just the path to it
'assumes it is in same directory with needed files
sourcePath = Left(sourcePath, _
InStrRev(sourcePath, Application.PathSeparator))
'kickstart things
sourceFileName = Dir$(sourcePath & "*.xls")
'don't do this if we found our own name
'Dir$() returns empty string after last file match
'is found
Do Until sourceFileName = ""
'double-check that it's an Excel file and
'that it is not a reference to this workbook
If sourceFileName <> ThisWorkbook.Name And _
UCase(Right(sourceFileName, 4)) = ".XLS" Then
'open that workbook without nagging about
'things like updating links and open it as
'read only
Application.DisplayAlerts = False
'keep from blinking the screen too much
Application.ScreenUpdating = False
Workbooks.Open sourcePath & sourceFileName, 0, True
'we may need/want to see alerts now, so
Application.DisplayAlerts = True
'the workbook becomes the active workbook when it
'is opened
Set sourceWB = ActiveWorkbook
'set a reference to the sheet we need
'for this example, the sheet's name is "Entry Sheet"
'and the data we want starts at A9 and continues down
'for an unknown number of rows, and we need to pick
'up data from columns A through H
Set sourceWS = sourceWB.Worksheets("Entry Sheet")
Set sourceBaseCell = sourceWS.Range("A9")
'find out where to start putting new data on
'the destination sheet in this workbook
'first, lets make this workbook the active one
ThisWorkbook.Activate
Set destBaseCell = _
destWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
'run down the rows in the source sheet until we hit
'an empty cell
RLC = 0 ' initialize/reset
Do While Not IsEmpty(sourceBaseCell)
'transfer data into this workbook
For CLC = 0 To 7 ' column A through H as offset from A
destBaseCell.Offset(RLC, CLC) = _
sourceBaseCell.Offset(0, CLC)
Next ' next column
'get new sourceBaseCell location
Set sourceBaseCell = sourceBaseCell.Offset(1, 0)
'update row pointer for this workbook's sheet
RLC = RLC + 1
Loop
'have hit empty cell in source book, done with it
'close without saving any changes
'do some housekeeping along the way
Set sourceBaseCell = Nothing
Set sourceWS = Nothing
sourceWB.Close False
Set sourceWB = Nothing
End If
Application.ScreenUpdating = True ' show results
'you could save sourceFileName somewhere at this
'point so you could later test to see if you have
'previously read data from it - that code, and
'the test to see if it's been read before is NOT
'included in this example
'
'get next possible filename
sourceFileName = Dir$()
Loop
'we are all done now
'do final housekeeping
Set destBaseCell = Nothing
Set destWS = Nothing
MsgBox "Data Retrieval Has Been Completed"
End Sub