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