Way to only import new files?

[shikamikamoomoo]

Below is code that I found on a site by Ron De Bruin. It seems to wor
well for what I am asking it to, but I am curious if there is a way t
speed it up. The folder that it is pulling information from has severa
hundred files and it takes a great deal of time. I'm not sure if perhap
I do not have the right code for this type of process or if there i
anything I can do other than sit and wait for it to update. Or I wa
wondering if there is a way to modify it to only update new files an
paste the information at the next available blank line.... Help i
appreciated. Thanks!

Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range


SaveDriveDir = CurDir
MyPath = "C:\Documents and Settings...."
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'clear all cells on the first sheet
'basebook.Worksheets(1).Cells.Clear

rnum = 2

Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)

Cnum = 1
For Each cell In mybook.Worksheets(1).Range("D4,I4,C6,D6")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell

mybook.Close False
rnum = rnum + 1
FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = False
End Su

 

[Ron de Bruin]

Hi shikamikamoomoo

I will make a example for you (also for the site)
Tomorrow or Saterday I post back (Busy on this moment)

 

[shikamikamoomoo]

Thank you so much!!! Greatly appreciated.

 

[Ron de Bruin]

Hi shikamikamoomoo

Here is one to test for you
Will finish it tomorrow and add it to the webpage

Copy the function also in the module

Sub Test_More_Areas()
Dim basebook As Workbook
Dim mybook As Workbook
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range

SaveDriveDir = CurDir
MyPath = "C:\Data"
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

Do While FNames <> ""

If IsError(Application.Match(FNames, _
basebook.Worksheets(1).Columns("A"), 0)) Then
rnum = LastRow(basebook.Worksheets(1)) + 1
Set mybook = Workbooks.Open(FNames)

' This will add the workbook name in column A if you want
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name

' Copy the cell values from each cell in one row starting in column B
Cnum = 2
For Each cell In mybook.Worksheets(1).Range("A2,A3,C2,C3,E2,E3")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell
mybook.Close False
End If
FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

 

[shikamikamoomoo]

hmmm...perhaps I am not copying this into the right location. I copied
the entire code into worksheet 1 and then the Function section into
module 1....is this right? It seems like it does something....but I'm
not sure what. It does not copy anything into the file.

 

[Ron de Bruin]

Copy both in a normal module(not a sheet module)

Change the path to yours

 

[Ron de Bruin]

I have update the site
http://www.rondebruin.nl/copy3.htm#new


--
Regards Ron de Bruin
http://www.rondebruin.nl

Hi shikamikamoomoo

I will make a example for you (also for the site)
Tomorrow or Saterday I post back (Busy on this moment)

 

[shikamikamoomoo]

I'm not sure what I am doing wrong, but I cannot get this to copy
anything over. I've tried copying the entire code including the
Function into Module 1. But when I run it nothing happens. Do I need
this code plus the original? I changed the path to the right location
and I do not get any errors.

 

[Ron de Bruin]

Send me your test file with the code private and I will see where you went wrong

 

[shikamikamoomoo]

Sent a copy of the file....thanks for your help

 

[Ron de Bruin]

Nothing in my Inbox ?

 

[shikamikamoomoo]

I sent it to the address on your site and it bounced back saying that
the server refused it. Spam block?

 

[Ron de Bruin]

Strange

Zip it and try again

 

[shikamikamoomoo]

Sent it again, this time the file is zipped.

 

[Ron de Bruin]

Have you used the correct address
(e-mail address removed)

 

[shikamikamoomoo]

Yes I'm sure that is the address that I used, same one that is on your
Excel Help site. I sent it again straight from here so this time it is
definately the address that I am using.

 

[shikamikamoomoo]

The file will be coming from (e-mail address removed) (in case it is
filtered in with junk mail)

 

[Ron de Bruin]

I send you a private mail

 

[shikamikamoomoo]

Replied to the email.....let me know if you still do not hear anything.
If this doesn't work, I'll try to send it from a different email address
later this evening.

 

[Ron de Bruin]

Nothing

How big is the file ?