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