Urgent help needed
Assuming that the row offsets for each step are the same, and building on
Nicks code...
Option Explicit
Private Sub CommandButton1_Click()
'Dim fso, workingFolder, files, currentFile
Dim FolderName As String, FileName As String, FilePath As String
Dim MasterWorkbookPath As String, MasterWorkbook As Workbook, MasterWS As
Worksheet
Dim ChildWorkbook As Workbook, ChildWS As Worksheet
Dim TestName As String, TestDescription As String
Dim StepExpectedResults As Variant, StepComments As String, StepDescription
As String, StepName As Long
Dim MoreTests, NoMoreRows As Boolean, WriteRow As Boolean
Dim CurrentRow As Long, CurrentWriteRow As Long
'Dim currentStep,
FolderName = "C:\testsToBeImported\"
MasterWorkbookPath = "C:\masterWorkbook.xls"
'Set fso = CreateObject("Scripting.FileSystemObject")
'Application.Visible = False
'Application.DisplayAlerts = False
Set MasterWorkbook = Application.Workbooks.Open(MasterWorkbookPath)
Set MasterWS = MasterWorkbook.Worksheets("import")
FileName = Dir(FolderName & "*.xls")
Do While FileName < ""
'Set workingFolder = fso.GetFolder(FolderName)
'Set files = workingFolder.files
CurrentWriteRow = 2
'For Each currentFile In files
'FileName = currentFile.Name
FilePath = FolderName & FileName
'MsgBox fileName
Set ChildWorkbook = Application.Workbooks.Open(FilePath)
'***
'***Added to loop through all worksheets
'***
For Each ChildWS In ChildWorkbook.Worksheets
'**** Initialize CurrentRow to beginning of Test template
CurrentRow = 1
With ChildWS
' **** We assume that valid test names have non-zero length
If .Cells(CurrentRow, 3).Value < "" Then
MoreTests = True
Else
MoreTests = False
End If
Do While MoreTests
'*****Added this loop to accomodate multiple tests per sheet
'***** From here on Refer to rows as offsets from currentrow
TestName = .Cells(CurrentRow, 3).Value
TestDescription = "Objective: " & .Cells(CurrentRow +1, 3).Value
TestDescription = TestDescription & Chr(13) & "Data Set: &
..Cells(CurrentRow+5, 4).Value"
TestDescription = TestDescription & Chr(13) & "Login Used: &
..Cells(CurrentRow + 6, 4).Value"
TestDescription = TestDescription & Chr(13) & "Preconditions: &
..Cells(CurrentRow + 7, 4).Value"
CurrentRow = CurrentRow + 10
NoMoreRows = False
WriteRow = False
StepName = 1
Do
StepDescription = .Cells(CurrentRow, 2).Value
'MsgBox stepDescription
'As StepDescription is declared as String,
IsNull(StepDescription) cannot = False
If Len(StepDescription) < 2 Then 'Or
(IsNull(StepDescription))) Then
CurrentRow = CurrentRow + 1
StepDescription = .Cells(CurrentRow, 2).Value
'As StepDescription is declared as String,
IsNull(StepDescription) cannot = False
If Len(StepDescription) < 2 Then 'Or
(IsNull(StepDescription))) Then
NoMoreRows = True
WriteRow = False
Else
WriteRow = True
End If
Else
WriteRow = True
End If
If WriteRow Then
StepExpectedResults = .Cells(CurrentRow, 4).Value
StepComments = .Cells(CurrentRow, 3).Value
StepDescription = StepDescription & Chr(13) & Chr(13) &
"Comments/Data: " & StepComments
MasterWS.Cells(CurrentWriteRow, 1).Value = "Import"
MasterWS.Cells(CurrentWriteRow, 2).Value = TestName
MasterWS.Cells(CurrentWriteRow, 3).Value = TestDescription
MasterWS.Cells(CurrentWriteRow, 4).Value = StepName
MasterWS.Cells(CurrentWriteRow, 5).Value = StepDescription
MasterWS.Cells(CurrentWriteRow, 6).Value =
StepExpectedResults
CurrentRow = CurrentRow + 1
CurrentWriteRow = CurrentWriteRow + 1
StepName = StepName + 1
End If
Loop Until NoMoreRows
' **** blank stepname could still mean there is another test
' **** need to skip one more row to test for this
CurrentRow = CurrentRow + 1
TestName = .Cells(CurrentRow, 3).Value
If Len(TestName) = 0 Then
'If a non-zero testname, then this sheet is done€¦
MoreTests = False
Else
' if not, then continue
MoreTests = True
End If
Loop 'MoreTests
End With
Next
ChildWorkbook.Close True, FilePath
'Set ChildWorkbook = Nothing
FileName = Dir()
Loop
MasterWorkbook.Save
MasterWorkbook.Close True, MasterWorkbookPath
'Application.Quit
'Set Application = Nothing
MsgBox "Import Formating Complete"
End Sub
|