To summaryze information from many workbooks without open it

[Frank Situmorang]

Hello,

In a server, I have about 300 workbooks in a server. All the workbooks are
indentical and have sheet named " SUMMARY". Without bothering people who
maybe using it, how can I get the information of each worksheet from the cell
range:
Range("C7,C8,E7,D118,H5,D63,E63,D70,F70," & _
"D80,F80,D102,F102,D108,D109")

and summaryize it in a workbook without opening each workbook. Should we use
ADO or DAO to do it?, Please help.

For your information if we open the workbook manuallly it prompts us to kein
the password, which is a window password, say "TopSecret", all the same
password for each workbook.

Thanks in advance,

Frank

 

[Ron de Bruin]

Hi Frank

You posted a few times this week but I hade no time to answer

Ado will not work with password protected workbooks
If it is one password for all workbooks use my Add-in to get the info
http://www.rondebruin.nl/merge.htm

Or use the code here
http://www.rondebruin.nl/copy3.htm
Read the tips part

 

[Frank Situmorang]

Thanks Ron for your quick response. I will try to use your code and have a
look at using code first. Hope that I can succeed.

Anyway, the problem now using windows password can not work as your first
example that already works for me. These are my codes base on your suggestion

Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D95,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
' Set FileNameXls = Workbooks.Open( _
' Filename:=PathStr & FileNameXls, _
' UpdateLinks:=0, _
' Password:="TopSecret", _
'WriteResPassword:="TopSecret")

'Set FileNameXls = ActiveWorkbook


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

 

[Frank Situmorang]

Ron:

I used your code and change neccessary parameter as mentioned in your
website, there is no more error message, but there is nothing in the sheet 1.

What did I miss here. Do you think it is because I assinged
"MergeSpecificWorkbooks" to a shape ( a kind of a button) in order to run the
macro?.

Or what is the ther "Kernell32", is it something that we must change?.

This is the whole VBA after my modification from yours:

Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub MergeSpecificWorkbooks()
Dim MyPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant


' Set application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

SaveDriveDir = CurDir
' Change this to the path\folder location of the files.
ChDirNet "\\Admin-hdd\budget-contr\BUDGET CONTROL M\BUDGET 2009"

FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*),
*.xl*", _
MultiSelect:=True)
If IsArray(FName) Then

' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1


' Loop through all files in the myFiles array.
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum), _
Password:="TIPTOP", WriteResPassword:="TIPTOP", UpdateLinks:=0)

On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next
With mybook.Worksheets("SUMMARY")
Set sourceRange =
..Range("C7,C8,E7,D118,H5,D63,E63,D70,F70," & _
"D80,F80,D102,F102,D108,D109")
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If the source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target
worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(FNum)
End With

' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)

' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count,
..Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next FNum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub

I appreciate your help Ron

Frank