Hi John
Here it is
I hade a strange problem if one of the sheets not exist, it will not calculate the formula when there is no data in the cell.
But the replace part at the end of the macro fix this (thanks to Dave Peterson)
Test this one for two sheets named Assay 1 and Assay 2
Sub Summary_cells_from_Different_Workbooks_Test()
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
Dim I As Long
ShName = "Assay " 'Test for two sheets named Assay 1 and Assay 2
Set Rng = Range("A1,D5:E5,Z10") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
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)
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
For I = 1 To 2 'test for Sheet1 and Sheet2
ColNum = 1
RwNum = RwNum + 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 & I & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number < 0 Then
Err.Clear
On Error GoTo 0
'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
Next I
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
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With
End If
End Sub
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
"Ron de Bruin" wrote in message ...
Hi John
It is evening here so I must go to soon but will create a example for you tomorrow
--
Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm
"John Yab" wrote in message ...
Hi Ron,
Thank you so much for your reply.
Values would be OK.
I have been trying on my own and have the code a little closer and the
new code is below and I have attached the new macro/workbook also.
You may have better ideas or methods though.
Sub Experiment7()
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 = "Assay 1" '<---- the name of the sheet searched
Set Rng = Range("B1,F1,F2,J1,J2,J3,F46,B67,F11:F23,M11:M23")
'<---- the cells to collect
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
SummWks.Name = "Summary"
'The links to the first workbook will start in row 2
RwNum = 1
'Create the array of filenames
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 2
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
'ssssss
'copy the worksheet name in column A
SummWks.Cells(RwNum, 2).Value = "Assay 1"
'sssssss
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName,
"'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" &
"Assay 1" & "'!"
On Error Resume Next
'SheetCheck = ExecuteExcel4Macro(PathStr &
Range("A1").Address(, , xlR1C1))
'If Err.Number < 0 Then
'If the sheet name that is being searched does not
exist in the workbook the row color will be Yellow.
'Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow
'Fill the collected data to the new workbook
'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
Columns("D:I").Insert Shift:=xlToRight
I had to cut the bottom of my paste because:
"The text that you have entered is too long (11885 characters). Please
shorten it to 10000 characters long."
Thanks,
John
Ron de Bruin;591638 Wrote:
Hi John
Do you want formula links or are values also OK
--
Regards Ron de Bruin
'Ron's Excel Tips' (http://www.rondebruin.nl/tips.htm)
"John Yab" wrote in message
...
I need a little help to modify some RDB code, please. Below is the
code. It
collects data from multiple workbooks that contain the worksheet
named:
"Assay 1". Could someone please assist me to modify the code so that
it would
collect data from the same workbooks for the times when a book also
contains
the worksheet named: "Assay 2".
Sub Experiment4()
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 = "Assay 1" '<---- the name of the sheet searched
Set Rng = Range("B1,F1,F2,J1,J2,J3,F46,B67,F11:F23,M11:M23")
'<----
the cells to collect
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel
Files,
*.xl*", MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
'Change ScreenUpdating and calculation to increase speed of
macro
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)
SummWks.Name = "Summary"
'The links to the first workbook will start in row 2
RwNum = 1
'Create the array of filenames
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 name that is being searched does not
exist in
the workbook the row color will be Yellow.
Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow
'Fill the collected data to the new workbook
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
Columns("C:H").Insert Shift:=xlToRight
Application.ErrorCheckingOptions.BackgroundCheckin g = False
Range("C2").FormulaR1C1 = "=AVERAGE(RC[13]:RC[25])"
Range("D2").FormulaR1C1 = "=MIN(RC[12]:RC[24])"
Range("E2").FormulaR1C1 = "=MAX(RC[11]:RC[23])"
Range("F2").FormulaR1C1 = "=AVERAGE(RC[23]:RC[35])"
Range("G2").FormulaR1C1 = "=MIN(RC[22]:RC[34])"
Range("H2").FormulaR1C1 = "=MAX(RC[21]:RC[33])"
FinalRow = SummWks.Cells(Rows.Count, 2).End(xlUp).Row
Range("C2:H2").AutoFill Destination:=Range("C2:H" & FinalRow)
'Add titles to columns and format to center some titles
Range("A1:AO1") = Array("Workbook Name", "Lot #", "Avg. Titre
cfu/g" &
Chr(10) & "Rhi", "Min. Titre cfu/g" & Chr(10) & "Rhi", _
"Max. Titre cfu/g" & Chr(10) & "Rhi", "Avg. Titre cfu/g" &
Chr(10) &
"Pb", "Min. Titre cfu/g" & Chr(10) & "Pb", _
"Max. Titre cfu/g" & Chr(10) & "Pb", "Date" & Chr(10) &
"Produced",
"Date" & Chr(10) & "Plated", "Granule", "Rz Inoculum", _
"Pb Inoculum", "Fumigatus", "Results", "Rz1", "Rz2", "Rz3",
"Rz4",
"Rz5", "Rz6", "Rz7", "Rz8", "Rz9", "Rz10", "Rz11", _
"Rz12", "Rz13", "Pb1", "Pb2", "Pb3", "Pb4", "Pb5", "Pb6",
"Pb7",
"Pb8", "Pb9", "Pb10", "Pb11", "Pb12", "Pb13")
Range("I:J").NumberFormat = "m/d/yyyy"
Range("A1:AO1").HorizontalAlignment = xlCenter
Rows("1:1").Font.Bold = True
Range("C:H").NumberFormat = "0.00E+00"
Range("N:N").NumberFormat = "0.00E+00"
Range("P:AO").NumberFormat = "0.00E+00"
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1:AO" & FinalRow),
,
xlYes).Name = _
"Table4"
Range("Table4[#All]").Select
ActiveSheet.ListObjects("Table4").TableStyle =
"TableStyleMedium3"
' Use AutoFit to set the column width in the new workbook
Columns.AutoFit
Columns("I:I").EntireColumn.AutoFit
'copy all the cells and then paste, special values to have the
data
displayed without formulas
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
End If
End Sub
--
John Yab
+-------------------------------------------------------------------+
|Filename: Summary Macro Experiment 7.xlsm |
|Download: http://www.thecodecage.com/forumz/attachment.php?attachmentid=396|
+-------------------------------------------------------------------+
--
John Yab
------------------------------------------------------------------------
John Yab's Profile: 1074
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=163867
Microsoft Office Help