LinkBack Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
 
Posts: 17
Default 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
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
trouble with Names on multiple sheets [email protected] Excel Worksheet Functions 1 May 28th 09 12:07 PM
Trouble with selecting multiple ranges of data markag Excel Worksheet Functions 2 June 23rd 06 04:35 PM
selecting multiple sheets Dennis Excel Programming 2 January 1st 04 08:06 PM
selecting multiple sheets Young-Hwan Choi Excel Programming 2 November 24th 03 01:19 AM
Changing the value in multiple sheets without selecting those sheets herm Excel Programming 3 October 14th 03 03:50 PM


All times are GMT +1. The time now is 09:00 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"