Adjust data range without opening multiple excel files

[Len]

Hi,

Codes below copied from the forum are adjusted to suit my need but I
have a problem to run the codes each time will open an excel file
which will take a few minutes particularly when there are >20 excel
files.

Is there a better way to run the codes without opening the excel file
and save the changes in another folder ? so that I do not have to
spend much time to run > 20 excel files


Sub ChgHeader()

Application.Calculation = xlCalculationManual

Dim wb As Workbook
Dim WBName As String
Dim WhatFolder As String

WhatFolder = "M:\CA\SP\Bdgt\BAl\dem3\"
ChDrive WhatFolder
ChDir WhatFolder
WBName = Dir("*.xls", vbNormal)
Do Until WBName = vbNullString
ChDir "M:\CA\SP\Bdgt\BAl\dem3"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = Workbooks.Open(WBName)
wb.Worksheets("P+L").Select
Dim i As Long
Dim Lstrow As Long
Lstrow = Cells(Rows.Count, "A").End(xlUp).Row
If Lstrow > 0 Then
For i = 5 To Lstrow
If Cells(i, 1).Value <> "" Then
Cells(i, 1).Copy
Cells(i, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End If
Next
Else
MsgBox "It appears that the file is empty, check the file again"
Exit Sub
End If
ChDir "M:\CA\SP\Bdgt\BAl\dem4"
wb.SaveAs Filename:=Left(WBName, InStrRev(WBName, ".") - 1),
FileFormat:=xlNormal

wb.Close SaveChanges:=True
WBName = Dir()
Loop

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True

End Sub

Any helps will be much appreciated as I'm beginner to vba prog


Regards
Len

 

[joel]

Since all microsfot office products use the same format you can open a
excel file like an Access Database. there are a few minor difference
like the spreadsheet names you have to add a dollar sign at the end. s
Any method you would use to get database from an Access Database wil
also work with an Excel workbook. You can query the workbook to rea
tthe data or use the ADO method.

Both types of reads use SQL to extract the data and is quicker tha
opening the workbooks. I have some example code that you can use t
start.

This code creates a databae and then writes. It is easy to start b
understandig how to create and write the database. Yo ucan search th
web and find plenty of examples by google for : Excel VBA ADO rea
Access

Public Const Folder = "C:\Temp\"
Public Const FName = "submission.mdb"
Sub MakeDataBase()

Const DB_Text As Long = 10
Const FldLen As Integer = 40


strDB = Folder & FName

If Dir(strDB) <> "" Then
MsgBox ("Database Exists - Exit Macro : " & strDB)
Exit Sub
End If

' Create new instance of Microsoft Access.
Set appAccess = CreateObject("Access.Application")
appAccess.Visible = True


' Open database in Microsoft Access window.
appAccess.NewCurrentDatabase strDB
' Get Database object variable.
Set dbs = appAccess.CurrentDb
' Create new table.
Set tdf = dbs.CreateTableDef("Submissions")

' Create Task/ID field in new table.
Set fld = tdf. _
CreateField("Task_ID", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Client Name field in new table.
Set fld = tdf. _
CreateField("Client Name", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Effective Date field in new table.
Set fld = tdf. _
CreateField("Effective Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Imp Mgr field in new table.
Set fld = tdf. _
CreateField("Imp Mgr", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Due Date field in new table.
Set fld = tdf. _
CreateField("Due Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Actual Date field in new table.
Set fld = tdf. _
CreateField("Actual Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

' Create Date Difference field in new table.
Set fld = tdf. _
CreateField("Date Difference", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld

dbs.TableDefs.Append tdf

Set appAccess = Nothing


End Sub

Sub Submit()
'filename of database is with MakeDatabase macro

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset

strDB = Folder & FName

If Dir(strDB) = "" Then
MsgBox ("Database Doesn't Exists, Create Database" & strDB)
MsgBox ("Exiting Macro")
Exit Sub
End If

ConnectStr = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Folder & FName & ";" & _
"Mode=Share Deny None;"

cn.Open (ConnectStr)
With rs
.Open Source:="Submissions", _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable

If .EOF <> True Then
.MoveLast
End If
End With

With Sheets("Internal Project Plan")

ClientName = .Range("B4")
ImpMgr = .Range("B5")
LaunchDate = .Range("C4")

LastRow = .Range("K" & Rows.Count).End(xlUp).Row
For RowCount = 7 To LastRow

If UCase(.Range("K" & RowCount)) = "X" Then

DueDate = .Range("E" & RowCount)
ActualDate = .Range("F" & RowCount)
DateDif = .Range("M" & RowCount)
Accurate = .Range("L" & RowCount)
Task_ID = .Range("B" & RowCount)

With rs
.AddNew
!Task_ID = Task_ID
![Client Name] = ClientName
![Effective Date] = LaunchDate
![Imp Mgr] = ImpMgr
![Due Date] = DueDate
![Actual Date] = ActualDate
![Date Difference] = DateDif

.Update
End With
End If
Next RowCount

End With

Set appAccess = Nothing
End Su

 

[Len]

Hi Joel,

Thanks for your advice, it will be great to use ADO to access, edit
excel file if I have time to do it
But due to time constraint to meet the deadline, for time being I need
to use back the above codes to run without opening excel files
I hope you will help me to modify my codes above just to meet the
deadline


Thanks & Regards
Len

 

[joel]

You can't read a workbook without openning it or using the ADO method.
I can fix the code to run much quicker. try these changes. I didn't
test the changes so try it in two new folders on one file before running
it on a whole directory.

change these two lines to test code.
SourceFolder = "M:\CA\SP\Bdgt\BAl\dem3\"
DestFolder = "M:\CA\SP\Bdgt\BAl\dem4"

Changing directories, selecting cells, copying rows one at a time is
extremely slow.



Sub ChgHeader()

Application.Calculation = xlCalculationManual

Dim wb As Workbook
Dim WBName As String
Dim WhatFolder As String
Dim i As Long
Dim Lstrow As Long

Application.DisplayAlerts = False
Application.ScreenUpdating = False

SourceFolder = "M:\CA\SP\Bdgt\BAl\dem3\"
DestFolder = "M:\CA\SP\Bdgt\BAl\dem4\"

WBName = Dir(SourceFolder & "*.xls", vbNormal)
Do Until WBName = vbNullString

Set wb = Workbooks.Open(SourceFolder & WBName)
With wb.Worksheets("P+L")
Lstrow = .Cells(Rows.Count, "A").End(xlUp).Row
If Lstrow >= 5 Then
Set CopyRange = .Range("A5:A" & Lstrow)
CopyRange.Copy _
Destination:=.Range("B5")
Else
MsgBox ("It appears that the file is empty : " & WBName)
Exit Do
End If

wb.SaveAs Filename:=DestFolder & WBName, FileFormat:=xlNormal

wb.Close SaveChanges:=True
WBName = Dir()
End With
Loop

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Application.EnableEvents = True

End Sub

 

[Len]

Joel,

Thanks for your quick reply.

It seems that it leave me no choice I have to use ADO
method............
It still very slow after I use your codes to test on one file and then
on whole directory

I'll work around on ADO method and see the progress
Thanks anyway

Regards
Len

 

[Len]

Joel,

I think I have a problem to use ADO method for several excel files
that had already been completed ( ie budget files already submitted
from 25 profit centers (BAI) and 22 cost centers (BAII) respectively
under budget directory(dem3) with 2 folders namely BAI and BAII
folders)

Now the problem is all budget files submitted with incorrect row
header format so I need to refill up the row header under column B in
one worksheet("P+L") from every budget file and thereafter I will
create named range in that "P+L" worksheet of every budget file. Later
I will proceed to create a summary budget via data consolidation

For data consolidate function, I will use keys selection of row,
column headers and create link to data source.

I'm in puzzle to which method is the most appropriate to run this
batch of excel files for data consolidation purpose, please advise

Regards
Len

 

[joel]

[I just noticed that you have application.enable events set to true a
the end of the program but never turn it off. Try turning it off a se
if you get any improvements in speed

 

[Len]

Joel,

Yep....Application.enable events already set to comment line ( ie turn
off ) and yet still no improvement


Regards
Len