I took some code that I wrote a while back and modified to loop through
a folder. the looping is simple
Folder = "c:\Temp\"
FName = Dir(Folder & "*.xls")
Do While FName < ""
DestFile = Folder & FName
Set cn = New ADODB.Connection
With cn
ConnectStr = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DestFile & ";" & _
"Mode=Share Deny None;" & _
"Extended Properties=""Excel 8.0;HDR=No;ReadOnly=False;"""
.Open (ConnectStr)
End With
'excel worksheet must have dollar sign at end of name
DestShtName = "Sheet1" & "$"
'open the recordset
Set rs = New ADODB.Recordset
With rs
MySQL = "SELECT * FROM [" & DestShtName & "] "
.Open Source:=MySQL, _
ActiveConnection:=cn
'-------------------------------------------------------
'enter your code here
'-------------------------------------------------------
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
FName = dir()
loop
------------------------------------
Sub MoveFolder()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set sourcesht = ThisWorkbook.Sheets("Sheet1")
Folder = "c:\Temp\"
FName = Dir(Folder & "*.xls")
Do While FName < ""
DestFile = Folder & FName
'excel worksheet must have dollar sign at end of name
DestShtName = "Sheet1" & "$"
With sourcesht
Person = .Range("A1")
EstWorkLoad = .Range("C4")
RealWorkLoad = .Range("C5")
WeekNum = .Range("F2")
End With
'open a connection, doesn't open the file
Set cn = New ADODB.Connection
With cn
ConnectStr = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DestFile & ";" & _
"Mode=Share Deny None;" & _
"Extended Properties=""Excel 8.0;HDR=No;ReadOnly=False;"""
.Open (ConnectStr)
End With
'open the recordset
Set rs = New ADODB.Recordset
With rs
MySQL = "SELECT * FROM [" & DestShtName & "] "
.Open Source:=MySQL, _
ActiveConnection:=cn
If .EOF < True Then
RowCount = 1
Do While Not .EOF And RowCount < 14
.MoveNext
RowCount = RowCount + 1
Loop
If .EOF Then
MsgBox ("Not Enough Rows - Exit macro")
End If
setLoad = ""
WorkWeekCol = 0
WorkWeek = 22
For Each Fld In rs.Fields
If Fld.Value = WorkWeek Then
'rows and columns are backwards from excel
WorkWeekCol = Range(Fld.Name).Row
Exit For
End If
Next Fld
End If
If WorkWeekCol = 0 Then
MsgBox ("Did not find WorkWeek : " & _
WorkWeek & ". Exiting Macro")
Exit Sub
End If
.Close
Person = "Joel"
MySQL = "SELECT *" & vbCrLf & _
"FROM [" & DestShtName & "] " & vbCrLf & _
"Where [" & DestShtName & ".F1]='" & Person & "'"
.Open Source:=MySQL, _
ActiveConnection:=cn, _
LockType:=adLockOptimistic, _
CursorType:=adCmdTable
If .EOF = True Then
MsgBox ("count not find : " & Person & " Exit Macro")
Exit Sub
Else
EstWorkLoad = 123
RealWorkLoad = 456
'field start at zero, subtract one from index
.Fields(WorkWeekCol - 1).Value = EstWorkLoad
.Fields(WorkWeekCol).Value = RealWorkLoad
.Update
End If
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
FName = Dir()
Loop
End Sub
--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:
http://www.thecodecage.com/forumz/sh...d.php?t=193439
http://www.thecodecage.com/forumz