Trouble selecting multiple sheets using RDB code

[John Yab]

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.BackgroundChecking = 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

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

'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

 

[Bob Phillips]

Haven't even attempted to test this, but try adding this code immediately
before the line

On Error Goto 0


'------------------------------------------


PathStr = "'" & JustFolder & "\[" & JustFileName & "]Assay 2'!"

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


---
HTH

Bob Phillips

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.BackgroundChecking = 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

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

'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]

Hi Bob,

Thanks for your reply. Unfortunately it didn't work. I will try to se
if I can work with it to see if it can be adapted though. I hav
attached my worksheet/macro and a couple of sample data sheets.
suppose I will also need to add a new column to the summary sheet title
"sheet" as well. Thanks again, I sure appreciate your help.

John

Haven't even attempted to test this, but try adding this cod
immediately
before the line

On Error Goto 0


'------------------------------------------


PathStr = "'" & JustFolder & "\[" & JustFileName & "]Assay 2'!"

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


---
HTH

Bob Phillips

I need a little help to modify some RDB code, please. Below is th code. It
collects data from multiple workbooks that contain the workshee named:
"Assay 1". Could someone please assist me to modify the code so tha 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:="Exce Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed o 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 no 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.BackgroundChecking = 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

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

'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

+-------------------------------------------------------------------+
|Filename: 0TPGP7002.xlsx |
|Download: http://www.thecodecage.com/forumz/attachment.php?attachmentid=394|
+-------------------------------------------------------------------+

 

[John Yab]

Hi Bob,

Thanks for your reply. Unfortunately it didn't work. I will try to see if I
can work with it to see if it can be adapted though. I have included a link
to where I have attached my worksheet/macro and a couple of sample data
sheets. I suppose I will also need to add a new column to the summary sheet
titled "sheet" as well. The additional code is bugging out and displaying a
box asking for me to select a sheet when sheet: "Assay 2" is not found. The
sheet: "Assay 2" will not be in all workbooks. Thanks again, I sure
appreciate your help.

http://www.thecodecage.com/forumz/e...ultiple-sheets-using-rdb-code.html#post591494


--
John Yab

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.BackgroundChecking = 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

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

'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

 

[Ron de Bruin]

Hi John

Do you want formula links or are values also OK

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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.BackgroundChecking = 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

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

'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]

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 th
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 no
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). Pleas
shorten it to 10000 characters long."


Thanks,
John

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)

I need a little help to modify some RDB code, please. Below is th code. It
collects data from multiple workbooks that contain the workshee named:
"Assay 1". Could someone please assist me to modify the code so tha it would
collect data from the same workbooks for the times when a book als 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:="Exce Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed o 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.BackgroundChecking = 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

+-------------------------------------------------------------------+
|Filename: Summary Macro Experiment 7.xlsm |
|Download: http://www.thecodecage.com/forumz/attachment.php?attachmentid=396|
+-------------------------------------------------------------------+

 

[Ron de Bruin]

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

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

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)

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.BackgroundChecking = 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

+-------------------------------------------------------------------+
|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/showthread.php?t=163867

Microsoft Office Help

 

[John Yab]

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.
You may have better ideas or methods though.


Also I have attached the revised workbook at
http://www.thecodecage.com/forumz/e...ultiple-sheets-using-rdb-code.html#post591657

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

'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 = 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
Application.ErrorCheckingOptions.BackgroundChecking = False

Range("D2").FormulaR1C1 = "=AVERAGE(RC[14]:RC[26])"
Range("E2").FormulaR1C1 = "=MIN(RC[13]:RC[25])"
Range("F2").FormulaR1C1 = "=MAX(RC[12]:RC[24])"
Range("G2").FormulaR1C1 = "=AVERAGE(RC[24]:RC[36])"
Range("H2").FormulaR1C1 = "=MIN(RC[23]:RC[35])"
Range("I2").FormulaR1C1 = "=MAX(RC[22]:RC[34])"

FinalRow = SummWks.Cells(Rows.Count, 3).End(xlUp).Row
Range("D2:I2").AutoFill Destination:=Range("D2:I" & FinalRow)

'Add titles to columns and format to center some titles
Range("A1:AP1") = Array("Workbook Name", "Sheet", "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("J:K").NumberFormat = "m/d/yyyy"
Range("A1:AP1").HorizontalAlignment = xlCenter
Rows("1:1").Font.Bold = True
Range("D:I").NumberFormat = "0.00E+00"
Range("O:O").NumberFormat = "0.00E+00"
Range("Q:AP").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:AP" & 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("J:J").EntireColumn.AutoFit

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

'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

Hi John

Do you want formula links or are values also OK

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

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.BackgroundChecking = 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

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

'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

.

 

[Ron de Bruin]

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

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

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

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)


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.BackgroundChecking = 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

+-------------------------------------------------------------------+
|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/showthread.php?t=163867

Microsoft Office Help

 

[Dave Peterson]

There is a chance that there would be no formulas in the summary worksheet.

Adding a couple of lines will prevent showing an error to the user:

on error resume next 'added
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With

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

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

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)


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.BackgroundChecking = 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/showthread.php?t=163867

Microsoft Office Help

 

[Ron de Bruin]

Good point Dave

But that would be a bad choice of a sheet name <g>

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

There is a chance that there would be no formulas in the summary worksheet.

Adding a couple of lines will prevent showing an error to the user:

on error resume next 'added
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With

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

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



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)


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.BackgroundChecking = 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/showthread.php?t=163867

Microsoft Office Help

 

[John Yab]

Hi Ron and Dave,

Thankyou very, very much.
I made some modifications and have more modifications to make but it does
work.
I changed the "Set Rng" so that it collects data from cells that display
test data returned better to see with.
I changed "ColNum" to = 2, now, so that the second column is now available
to add the sheet name.
Just under:

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

I added:

'copy the worksheet name in column B
SummWks.Cells(RwNum, 2).Value = ShName & I

and now the sheet name (either "Assay 1" or "Assay 2") displays in the
summary.
A remaining issue that I will solve is the summary returned shows 2 rows
for each: Assay 1 and Assay 2 regardless that in some cases there will not be
an Assay 2 test. I will add code to find all the blanks in a column and then
delete the entire row of those with blanks. I am very grateful for your help.

Ron, you have an excellent web and one of your pages gives me and idea that
maybe I should have used ?? instead:
http://www.rondebruin.nl/copy2.htm
As I think I understand it, this method opens (briefly) each workbook to
collect data and rapidly closes each workbook instead of the method that I am
using. I really like the part in your code on this page that goes like this:

"Replace this line:
If sh.Name <> DestSh.Name Then

With:
If LCase(Left(sh.Name, 4)) = "week" Then

If you want to copy only from sheets with a name that start with week."

This looks like something that might work for my situation but your web page
discribes this method in the context of copying a range such as:
"Set CopyRng = sh.Range("A1:G1")"

In my situation I am try to do 2 things: 1) collect data from a lot of non
continuous ranges (Range("B1,F1,F2,J1,J2,J3,F46,B67,F11:F23,M11:M23") and 2)
collect data from worksheets that start with "Assay."
Is there a way to combine these 2 situations to make it work with your
methods on your web page: http://www.rondebruin.nl/copy2.htm?
--
John Yab

There is a chance that there would be no formulas in the summary worksheet.

Adding a couple of lines will prevent showing an error to the user:

on error resume next 'added
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With

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

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



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)


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 &

 

[Ron de Bruin]

Hi John

The copy2 page is for worksheets in the same workbook

See this page for workbooks
http://www.rondebruin.nl/copy3.htm

Try my add-in fist maybe you like it (it have a option for non continuous ranges and a sheet filter option)
http://www.rondebruin.nl/merge.htm

The code above not on this moment but it is possible to change


If you want no empty rows if there is no Assay 2 you can change this part of the code

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

ColNum = 1
RwNum = RwNum + 1

'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
RwNum = RwNum - 1
Else
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

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





--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Hi Ron and Dave,

Thankyou very, very much.
I made some modifications and have more modifications to make but it does
work.
I changed the "Set Rng" so that it collects data from cells that display
test data returned better to see with.
I changed "ColNum" to = 2, now, so that the second column is now available
to add the sheet name.
Just under:

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

I added:

'copy the worksheet name in column B
SummWks.Cells(RwNum, 2).Value = ShName & I

and now the sheet name (either "Assay 1" or "Assay 2") displays in the
summary.
A remaining issue that I will solve is the summary returned shows 2 rows
for each: Assay 1 and Assay 2 regardless that in some cases there will not be
an Assay 2 test. I will add code to find all the blanks in a column and then
delete the entire row of those with blanks. I am very grateful for your help.

Ron, you have an excellent web and one of your pages gives me and idea that
maybe I should have used ?? instead:
http://www.rondebruin.nl/copy2.htm
As I think I understand it, this method opens (briefly) each workbook to
collect data and rapidly closes each workbook instead of the method that I am
using. I really like the part in your code on this page that goes like this:

"Replace this line:
If sh.Name <> DestSh.Name Then

With:
If LCase(Left(sh.Name, 4)) = "week" Then

If you want to copy only from sheets with a name that start with week."

This looks like something that might work for my situation but your web page
discribes this method in the context of copying a range such as:
"Set CopyRng = sh.Range("A1:G1")"

In my situation I am try to do 2 things: 1) collect data from a lot of non
continuous ranges (Range("B1,F1,F2,J1,J2,J3,F46,B67,F11:F23,M11:M23") and 2)
collect data from worksheets that start with "Assay."
Is there a way to combine these 2 situations to make it work with your
methods on your web page: http://www.rondebruin.nl/copy2.htm?
--
John Yab

There is a chance that there would be no formulas in the summary worksheet.

Adding a couple of lines will prevent showing an error to the user:

on error resume next 'added
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With

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

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



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)


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 &

 

[John Yab]

Hi Ron,

I love your add-in and yes... it works perfectly.
I have some special needs that I wanted to make the the stand alone macro
for and also it has been a great learning experience going through your code.

I have used both ideas to remove the extra rows... first I used the find all
the blanks in a column and then
deleted the entire row of those with blanks and that worked.
Then I read your additional post and it worked too. I modified it a bit and
learned that I had to be careful where I added:

SummWks.Cells(RwNum, 2).Value = ShName & I

I modified it to have the summary show the sheet name in column "B" and it
looks like this:

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 = 2
'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
RwNum = RwNum + 1

'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
RwNum = RwNum - 1

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

'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
SummWks.Cells(RwNum, 2).Value = ShName & I
'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa

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


I have run out of day today and will study:
http://www.rondebruin.nl/copy3.htm
tomorrow. Thankyou very much Ron.
--
John Yab

Hi John

The copy2 page is for worksheets in the same workbook

See this page for workbooks
http://www.rondebruin.nl/copy3.htm

Try my add-in fist maybe you like it (it have a option for non continuous ranges and a sheet filter option)
http://www.rondebruin.nl/merge.htm

The code above not on this moment but it is possible to change


If you want no empty rows if there is no Assay 2 you can change this part of the code

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

ColNum = 1
RwNum = RwNum + 1

'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
RwNum = RwNum - 1
Else
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

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





--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

Hi Ron and Dave,

Thankyou very, very much.
I made some modifications and have more modifications to make but it does
work.
I changed the "Set Rng" so that it collects data from cells that display
test data returned better to see with.
I changed "ColNum" to = 2, now, so that the second column is now available
to add the sheet name.
Just under:

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

I added:

'copy the worksheet name in column B
SummWks.Cells(RwNum, 2).Value = ShName & I

and now the sheet name (either "Assay 1" or "Assay 2") displays in the
summary.
A remaining issue that I will solve is the summary returned shows 2 rows
for each: Assay 1 and Assay 2 regardless that in some cases there will not be
an Assay 2 test. I will add code to find all the blanks in a column and then
delete the entire row of those with blanks. I am very grateful for your help.

Ron, you have an excellent web and one of your pages gives me and idea that
maybe I should have used ?? instead:
http://www.rondebruin.nl/copy2.htm
As I think I understand it, this method opens (briefly) each workbook to
collect data and rapidly closes each workbook instead of the method that I am
using. I really like the part in your code on this page that goes like this:

"Replace this line:
If sh.Name <> DestSh.Name Then

With:
If LCase(Left(sh.Name, 4)) = "week" Then

If you want to copy only from sheets with a name that start with week."

This looks like something that might work for my situation but your web page
discribes this method in the context of copying a range such as:
"Set CopyRng = sh.Range("A1:G1")"

In my situation I am try to do 2 things: 1) collect data from a lot of non
continuous ranges (Range("B1,F1,F2,J1,J2,J3,F46,B67,F11:F23,M11:M23") and 2)
collect data from worksheets that start with "Assay."
Is there a way to combine these 2 situations to make it work with your
methods on your web page: http://www.rondebruin.nl/copy2.htm?
--
John Yab

There is a chance that there would be no formulas in the summary worksheet.

Adding a couple of lines will prevent showing an error to the user:

on error resume next 'added
With SummWks.Cells.SpecialCells(xlCellTypeFormulas)
.Replace what:="=", replacement:="=", _
lookat:=xlPart, searchorder:=xlByRows, _
MatchCase:=False
End With
on error goto 0 'added



Ron de Bruin wrote:

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

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



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" & "'!"