Xld,
I took out the transpose as you suggested and it works exactly as intended! If you are curious run the data workbook I sent with this code, pretty neat!
Sub RunReport()
' Sets screen to not update for faster execution
Application.ScreenUpdating = False
' Establish All Workbook and Worksheet Variables
Dim WBT As Workbook ' This Workbook
Dim WBD As Workbook ' Data Workbook
Dim WSD As Worksheet ' Data Sheet from data workbook
Dim WPN As Worksheet ' Report, in WBT
Set WBT = ThisWorkbook ' Sets 'WBT' equal to a workbook variable assigned to the seed file
' Variable assignment
Dim fso As New FileSystemObject ' Enables macro to search file explorer for files
Dim mtwFiles As Variant ' String that holds the file name
Dim ReamerID As String, Operator As String
ReamerID = Application.InputBox("Enter Reamer ID to be Analyzed.")
Operator = Application.InputBox("Enter Operators Seperated by a Comma.")
mtwFiles = Application.GetOpenFilename("mtwData Files (*.), *.mtwData)", 1, "Select Desired File.", "Select", False) ' Gets file names of shift/ctrl clicked files
' Stop formula updates for faster execution
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' If file not chosen, break
If mtwFiles = False Then
MsgBox ("File not chosen.")
GoTo EndSub
Else
End If
''''''''''''' Open Workbook with m'th string name from mtwFiles string array
dataWorkbookFileName = fso.GetFileName(mtwFiles) ' Gets filename of file
Workbooks.Open mtwFiles ' Opens .mtwData Workbook
''''''''''''' Set workbook and worksheet variables
Set WBD = Workbooks(dataWorkbookFileName) ' 'WBD' gets set to the .mtwData workbook
Set WSD = WBD.Sheets(1) ' 'WSD' is the first sheet (the only sheet) in the .mtwData workbook
Set WPN = WBT.Sheets(1) ' 'WPN' is the first sheet (data table) in this report macro workbook
' Data workbook variable assignment
Const BLOCK_END As String = "DONE"
Dim rng As Range
Dim cell As Range
Dim aryColA As Variant
Dim aryColB As Variant
Dim firstAddress As String
Dim numArrays As Long
Dim idxArrays As Long
Dim firstrow As Long
Dim lastrow As Long
Dim numrows As Long
With WSD
numArrays = Application.CountIf(.Columns(1), BLOCK_END)
ReDim aryColA(1 To numArrays)
ReDim aryColB(1 To numArrays)
idxArrays = 1
firstrow = 2
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(lastrow, "A").Value <> BLOCK_END Then
lastrow = lastrow + 1
.Cells(lastrow, "A").Value = BLOCK_END
End If
Set rng = .Range("A2").Resize(lastrow - 1)
Set cell = Nothing
Set cell = .Columns(1).Find(What:=BLOCK_END, _
After:=.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
lastrow = cell.Row
numrows = lastrow - firstrow
If numrows > 1 Then
aryColA(idxArrays) = .Cells(firstrow, "A").Resize(numrows)
aryColB(idxArrays) = .Cells(firstrow, "B").Resize(numrows)
idxArrays = idxArrays + 1
End If
firstrow = lastrow + 2
Set cell = .Columns(1).FindNext(cell.Offset(1, 0))
Loop While Not cell Is Nothing And cell.Address <> firstAddress And cell.Row <> 1
End If
End With
For wert = 1 To numArrays
' Copies previous sample's sheet to format for new sample
If WBT.Sheets(2).Cells(1, 2).Value = "" Then ' If this is the first sample
Set NewSheet = WBT.Sheets(WBT.Sheets.Count)
NewSheet.Name = "Hole 1" ' Changes this new sheets name to the specimen's name
Else
WBT.Sheets(WBT.Sheets.Count).Copy After:=WBT.Sheets(WBT.Sheets.Count) ' Copies previous sheet
Set NewSheet = WBT.Sheets(WBT.Sheets.Count) ' Sets NewSheet variable to new sheet
NewSheet.Range("A48:B15000").ClearContents ' Clears raw data values on specimen sheet starting on row 4
NewSheet.Name = "Hole " & wert ' Changes sheet name
End If
' Find max pos value
MaxDepth = WorksheetFunction.Min(aryColB(wert))
' Paste arrays into specimens worksheet (starting at row 48)
NewSheet.Range("A48:A" & UBound(aryColA(wert)) + 1) = aryColA(wert)
NewSheet.Range("B48:B" & UBound(aryColB(wert)) + 1) = aryColB(wert)
' Assign values to specimen's sheet
With NewSheet
.[B1].Value = NewSheet.Name
.[B3].Value = MaxDepth
End With
Next wert
' Assign Values to Spreadsheet on Sheet 1
With WPN
.Cells(5, 6).Value = Operator
.Cells(5, 8).Value = numArrays
End With
' Calculate Formulas
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
' Format by closing Data workbooks, and setting focus to 'Report' tab
Application.DisplayAlerts = False
Workbooks(dataWorkbookFileName).Close
Application.DisplayAlerts = True
WPN.Activate
' Sets screen updating back to true
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
' Prompt to save as .xlsm
saveAsName = Application.GetSaveAsFilename
If saveAsName = "False" Then
Else
WBT.SaveAs Filename:=saveAsName & "xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
End If
EndSub:
' Sets screen updating back to true
Application.ScreenUpdating = True
End Sub
Thank you so much for your assistance, this has been extremely helpful!
Reply With Quote
