Where am I going wrong?

[tljenkin]

Hi All,

I have the following code below. It is supposed to do the following:

1) Ask user if file is open, if yes, check that the file is indeed open, activate file and run the code

2) If file is not open, it should ask user to select file to open, then run the code.

I am getting all sorts of End If or Do Loop error messages including at one time nothing happening after you answer "NO" to file is not open.

Can someone please look at code and tell me whats errors are in there?

Many Thanks



Sub UpdateDatabase()

Dim FileToBeOpened As Variant, File As Variant, Ard As Workbook, Wrr As Workbook, wb As Workbook
Dim strLastWeek As String, strThisWeek As String
Dim lLastRowColA As Long, lLastRowColB As Long

Set Ard = ThisWorkbook ' or Actuals repository current version presently open

Application.ScreenUpdating = False

Response = MsgBox(prompt:="Is the most recent weekly Redress report open?", Buttons:=vbYesNo)
If Response = vbYes Then
For Each Wrr In Application.Workbooks
If Wrr.Name Like "Week*" Then
Set wb = Wrr
wb.Activate
Exit For
End If
Next Wrr
Else
If wb Is Nothing Then
MsgBox "The file is not open."
End If
Exit Sub
Do
Sheets("Tracking Report").Select
Application.Goto Reference:="R5C2:R500C38"
Selection.Copy

'Define the final row
Ard.Activate
Sheet13.Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
NextRow = FinalRow + 1
Cells(NextRow, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

'---get last row of Columns A and B
lLastRowColA = Range("A" & Rows.Count).End(xlUp).Row
lLastRowColB = Range("B" & Rows.Count).End(xlUp).Row
If lLastRowColA = lLastRowColB Then Exit Sub


'---increment last week by 1 to make string for this week
strLastWeek = Range("A" & lLastRowColA).Value
If Left(strLastWeek, 4) = "Week" Then
strThisWeek = "Week" & Mid(strLastWeek, 5) + 1
Else
MsgBox "Error: Last Cell in Col A is: " & strLastWeek
End If
'---fill in Col A for this week's records
Range(Range("A" & lLastRowColA + 1), _
Range("A" & lLastRowColB)).Value = strThisWeek


Calculate
ActiveWorkbook.RefreshAll
Sheet22.Activate
Wrr.Close (False)
Application.ScreenUpdating = True



If Response = vbNo Then


On Error GoTo 0
FileToBeOpened = Application.GetOpenFilename(FileFilter:="All Excel Files (*.xls*), *.xls*", Title:="Where is the most recent weekly Redress file?", MultiSelect:=False)
Application.ScreenUpdating = False

' Exit if user exits dialog
If FileToBeOpened = False Then Exit Sub

' Open file (Wrr), copy most recent weekly redress data to the Actuals Repository
Set Wrr = Workbooks.Open(FileToBeOpened)
Wrr.Activate
Loop

End Sub

 

[Andrew Poulsom]

What's the purpose of the Do ... Loop construct there? This compile OK but I haven't tested it:

Sub UpdateDatabase()
    Dim Response As VbMsgBoxResult
    Dim FinalRow As Long
    Dim NextRow As Long
    Dim FileToBeOpened As Variant, File As Variant, Ard As Workbook, Wrr As Workbook, wb As Workbook
    Dim strLastWeek As String, strThisWeek As String
    Dim lLastRowColA As Long, lLastRowColB As Long
    Set Ard = ThisWorkbook ' or Actuals repository current version presently open
    Application.ScreenUpdating = False
    Response = MsgBox(prompt:="Is the most recent weekly Redress report open?", Buttons:=vbYesNo)
    If Response = vbYes Then
        For Each Wrr In Application.Workbooks
            If Wrr.Name Like "Week*" Then
                Set wb = Wrr
                wb.Activate
                Exit For
            End If
        Next Wrr
        If wb Is Nothing Then
            MsgBox "The file is not open."
            Exit Sub
        End If
     ElseIf Response = vbNo Then
        On Error GoTo 0
        FileToBeOpened = Application.GetOpenFilename(FileFilter:="All Excel Files (*.xls*), *.xls*", Title:="Where is the most recent weekly Redress file?", MultiSelect:=False)
        Application.ScreenUpdating = False
'       Exit if user exits dialog
        If FileToBeOpened = False Then Exit Sub
'       Open file (Wrr), copy most recent weekly redress data to the Actuals Repository
        Set Wrr = Workbooks.Open(FileToBeOpened)
        Wrr.Activate
    End If
    Sheets("Tracking Report").Select
    Application.Goto Reference:="R5C2:R500C38"
    Selection.Copy
'   Define the final row
    Ard.Activate
    Sheet13.Select
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    NextRow = FinalRow + 1
    Cells(NextRow, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'   ---get last row of Columns A and B
    lLastRowColA = Range("A" & Rows.Count).End(xlUp).Row
    lLastRowColB = Range("B" & Rows.Count).End(xlUp).Row
    If lLastRowColA = lLastRowColB Then Exit Sub
'   ---increment last week by 1 to make string for this week
    strLastWeek = Range("A" & lLastRowColA).Value
    If Left(strLastWeek, 4) = "Week" Then
        strThisWeek = "Week" & Mid(strLastWeek, 5) + 1
    Else
        MsgBox "Error: Last Cell in Col A is: " & strLastWeek
    End If
'   ---fill in Col A for this week's records
    Range(Range("A" & lLastRowColA + 1), _
    Range("A" & lLastRowColB)).Value = strThisWeek
    Calculate
    ActiveWorkbook.RefreshAll
    Sheet22.Activate
    Wrr.Close (False)
    Application.ScreenUpdating = True
End Sub

When posting code in future please use code tags:

http://www.mrexcel.com/forum/misc.php?do=bbcode#code

 

[tljenkin]

The Do Loop was supposed to repeat the same actions if the answer is No. I was trying to avoid pasting the whole code again below the If vbanswer = No.

I am guessing that is wrong?

 

[Andrew Poulsom]

If the answer if Yes, the code checks that the workbook is open and if not its exits the sub. If the answer is no the workbook is opened. The rest of the code processes that workbook (I hope).

 

[tljenkin]

oK will test this code and get back asap. 5 mins

 

[tljenkin]

It works fine up to this point (see below). Everything after that is not executed. Please help

---get last row of Columns A and B
lLastRowColA = Range("A" & Rows.Count).End(xlUp).Row
lLastRowColB = Range("B" & Rows.Count).End(xlUp).Row
If lLastRowColA = lLastRowColB Then Exit Sub
' ---increment last week by 1 to make string for this week
strLastWeek = Range("A" & lLastRowColA).Value
If Left(strLastWeek, 4) = "Week" Then
strThisWeek = "Week" & Mid(strLastWeek, 5) + 1
Else
MsgBox "Error: Last Cell in Col A is: " & strLastWeek
End If
' ---fill in Col A for this week's records
Range(Range("A" & lLastRowColA + 1), _
Range("A" & lLastRowColB)).Value = strThisWeek
Calculate
ActiveWorkbook.RefreshAll
Sheet22.Activate
Wrr.Close (False)
Application.ScreenUpdating = True

 

[tljenkin]

Is there a way to print and test each of the lines in the last post above to make sure they do work? Thanks

 

[Andrew Poulsom]

You can insert a breakpoint and step through the code.

http://www.cpearson.com/excel/debug.htm