PDA

View Full Version : VBA Macro Summary Sheet



mroy6283
03-31-2015, 08:12 AM
Hello

I need some help with some coding. I am a mechanical engineering student on co op and am not really familiar with visual basic. I need my code to parse through all the files in a certain, pull out a specific row in each spreadsheet and then paste that to a summary sheet. Now this specific row is different every sheet because it is raw data from testing. However, it is always from column B:K just the row changes as it is the average of the last 10 data points collected. I have something already written and it works but it grabs the right line for the first file but then uses that row for all the other files and like I mentioned above that is not the case, the row changes. Here is the code: Any help would be so great!:


Sub Summary_cells_from_Different_Workbooks_1()
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 WS As Worksheet
Dim SelRange As Range
Dim LastRowNum As Long
Set WS = Worksheets("Sheet1")
LastRowNum = WS.Range("B" & Rows.Count).End(xlUp).Row


WS.Activate
Range("B" & LastRowNum & ":" & "K" & LastRowNum).Select
Set SelRange = Selection

ShName = "Sheet1" '<---- Change
Set Rng = SelRange


'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)
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 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
On Error GoTo 0
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
End If
End Sub

Bob Phillips
04-01-2015, 02:29 AM
Post 3 or 4 of the data workbooks for us to work with.