Excel 2016 VBA Error 400

[KJH]

Hello,

I'm running just a simple batch processing macro to prepare an alternative sheet which will be used for a mass upload into my database. The process is simple, I want the macro to evaluate the string inputed by my analysts and assign variables several set values based off of the input. Using those variables I create the new sheet. Simple enough, unless I get a VBA error code 400 which gives zero explanation as to why/what is the error. Please help, amateur hour needs to end!!!

Sub WeeklyResearch_MassUpload_Format()
Dim issuetype As String
Dim status As String
Dim action As String
Dim RecommendedAction As String
Dim WRrowcount As Long
Dim MUrownum As Long
Dim SKU As Long
Dim PartnerName As String
Dim partnernum As Long
Dim pqass As String 'lol
Dim issrcgnz As String
Dim logid As Integer
Dim opendate As String 'Just for testing purposes, later, change to date.
Dim analysis As String
Dim WR As Worksheet
Dim massupload_print As Worksheet

Set WR = Sheets("Weekly_Research")
Set massupload_print = Sheets("MassUpload_Print")

WR.Cells(1, 6).Activate
ActiveCell.End(xlDown).Activate

MUrownum = 1
logid = 5
opendate = "February 26th, 2016"
issrcgnz = "Weekly Workbooks"

Application.ScreenUpdating = False
WRrowcount = WR.Range("C1").CurrentRegion.Rows.Count


'Loop Processing
Do While ActiveCell.Row < (WRrowcount + 1)
'Filter out Good, Watch, Physical Audit from processing
Do While (InStr(1, ActiveCell, "Good", vbTextCompare) > 0 Or InStr(1, ActiveCell, "Watch", vbTextCompare) > 0 Or InStr(1, ActiveCell, "Physical", vbTextCompare) > 0)
If InStr(1, ActiveCell, "Good", vbTextCompare) > 0 Then
ActiveCell.Offset(1, 0).Activate
If IsEmpty(ActiveCell) Then
ActiveCell.End(xlDown).Activate
End If
ElseIf InStr(1, ActiveCell, "Watch", vbTextCompare) > 0 Then
ActiveCell.Offset(1, 0).Activate
If IsEmpty(ActiveCell) Then
ActiveCell.End(xlDown).Activate
End If
ElseIf InStr(1, ActiveCell, "Physical Audit", vbTextCompare) > 0 Then
ActiveCell.Offset(1, 0).Activate
If IsEmpty(ActiveCell) Then
ActiveCell.End(xlDown).Activate
End If
End If
Loop

'Defining IssueType
If Left(ActiveCell, 2) = "AR" Then
issuetype = "At Risk"
ElseIf Left(ActiveCell, 2) = "HR" Then
issuetype = "High Risk"
ElseIf Left(ActiveCell, 2) = "RH" Then
issuetype = "Return Hold Report"
ElseIf Left(ActiveCell, 2) = "Co" Then
issuetype = "Item Enhancement"
ElseIf Left(ActiveCell, 2) = "Im" Then
issuetype = "Item Enhancement"
End If

'Defining Status
If issuetype = "At Risk" Then
status = "Open"
ElseIf issuetype = "High Risk" Then
status = "Open"
ElseIf issuetype = "Item Enhancement" Then
status = "Open"
ElseIf issuetype = "Return Hold Report" Then
status = "Return Hold"
End If

'Defining Recommended Action
If InStr(1, ActiveCell, "Packaging Issue", vbTextCompare) > 0 Then
RecommendedAction = "Please review and update packaging of this product. Please send images of packaging improvements or a new drop test report."
ElseIf InStr(1, ActiveCell, "Defective Item", vbTextCompare) > 0 Then
RecommendedAction = "Please perform inventory check to remove defective product. Please advise once this has been done."
ElseIf InStr(1, ActiveCell, "Received Wrong Item", vbTextCompare) > 0 Then
RecommendedAction = "Please check UPCs to ensure that they match SKU number(s). Please check inventory to ensure that product is labeled correctly."
ElseIf InStr(1, ActiveCell, "Missing Parts", vbTextCompare) > 0 Then
RecommendedAction = "Please perform inventory check to ensure that product arrives complete. Please advise once this has been done."
ElseIf InStr(1, ActiveCell, "Copy Issue", vbTextCompare) > 0 Then
RecommendedAction = analysis
ElseIf InStr(1, ActiveCell, "Image Issue", vbTextCompare) > 0 Then
RecommendedAction = analysis
End If

'Reformatting the Action
If InStr(1, ActiveCell, "Packaging Issue", vbTextCompare) > 0 Then
action = "Packaging Issue"
ElseIf InStr(1, ActiveCell, "Defective Item", vbTextCompare) > 0 Then
action = "Defective Item"
ElseIf InStr(1, ActiveCell, "Received Wrong Item", vbTextCompare) > 0 Then
action = "Received Wrong Item"
ElseIf InStr(1, ActiveCell, "Missing Parts", vbTextCompare) > 0 Then
action = "Missing Parts"
End If

MUrownum = MUrownum + 1
SKU = ActiveCell.Offset(0, -3)
pqass = ActiveCell.Offset(0, 6)
PartnerName = ActiveCell.Offset(0, 7)
partnernum = ActiveCell.Offset(0, 8)
analysis = ActiveCell.Offset(0, 1)
ActiveCell = action
ActiveCell.Offset(0, -2) = issuetype
ActiveCell.Offset(0, -1) = status
ActiveCell.Offset(0, 2) = RecommendedAction

massupload_print.Cells(MUrownum, 1) = logid
massupload_print.Cells(MUrownum, 2) = opendate
massupload_print.Cells(MUrownum, 3) = SKU
massupload_print.Cells(MUrownum, 4) = status
massupload_print.Cells(MUrownum, 5) = issuetype
massupload_print.Cells(MUrownum, 6) = pqass
massupload_print.Cells(MUrownum, 7) = issrcgnz
massupload_print.Cells(MUrownum, 8) = action
massupload_print.Cells(MUrownum, 9) = analysis
massupload_print.Cells(MUrownum, 10) = RecommendedAction
massupload_print.Cells(MUrownum, 11) = partnernum
massupload_print.Cells(MUrownum, 12) = PartnerName


'navigation through workbook...
If ActiveCell.Offset(1, 0) <> Empty Then
ActiveCell.Offset(1, 0).Activate
ElseIf ActiveCell.End(xlDown).Row < (WRrowcount + 1) Then
ActiveCell.End(xlDown).Activate
End If

If ActiveCell.Row > (WRrowcount + 1) Then
Exit Do
End If
Loop

Application.ScreenUpdating = True
WR.Cells(1, 1).Activate


'MsgBox ("Thanks for playing, have a nice day")
End Sub

[Paul_Hossler]

1. Welcome to the forum

2. You can use the [#] icon to add CODE tags and put your macro between

3. 400's are annoying, but if you single step through, does it fail on a line?

4. Can you post a sample workbook with the macro and enough data to show the issue?

[KJH]

VBA Example-TESTBOOK.xlsm Attached you'll find a watered down version of it.It's throwing a different error now, what are your thoughts

[Paul_Hossler]

I get the error also

I think that there's too much .Activate-ing going on

You really don't need to activate or select things to use or update them

As example, I rearchitected the first part to just use a simple counter loop and just use/update cells directly

Didn't do the rest, but this will give you the idea

Option Explicit
Sub WeeklyResearch_MassUpload_Format()
    Dim issuetype As String
    Dim status As String
    Dim action As String
    Dim RecommendedAction As String
    Dim WRrowcount As Long
    Dim MUrownum As Long
    Dim SKU As Long
    Dim PartnerName As String
    Dim partnernum As Long
    Dim pqass As String 'lol
    Dim issrcgnz As String
    Dim logid As Integer
    Dim opendate As String 'Just for testing purposes, later, change to date.
    Dim analysis As String
    Dim WR As Worksheet
    Dim massupload_print As Worksheet
    
    Dim iRow As Long        '   <<<<<<<<<<<<<<<<
    
    Set WR = Sheets("Weekly_Research")
    Set massupload_print = Sheets("MassUpload_Print")
        
    MUrownum = 1
    logid = 5
    opendate = "February 26th, 2016"
    issrcgnz = "Weekly Workbooks"
    
    Application.ScreenUpdating = False
    
    For iRow = 3 To WR.Cells(1, 1).CurrentRegion.Rows.Count
    
        With WR.Rows(iRow)
            'Filter out Good, Watch, Physical Audit from processing
            If InStr(1, .Cells(6).Value, "Good", vbTextCompare) > 0 Then GoTo SkipRow
            If InStr(1, .Cells(6).Value, "Watch", vbTextCompare) > 0 Then GoTo SkipRow
            If InStr(1, .Cells(6).Value, "Physical", vbTextCompare) > 0 Then SkipRow
    
            
            'Defining IssueType Defining Status
            Select Case Left(.Cells(6).Value, 2)
                Case "AR"
                    issuetype = "At Risk"
                    status = "Open"
                Case "HR"
                    issuetype = "High Risk"
                    status = "Open"
                Case "RH"
                    issuetype = "Return Hold Report"
                    status = "Return Hold"
                Case "Co"
                    issuetype = "Item Enhancement"
                Case "Im"
                    issuetype = "Item Enhancement"
                    status = "Open"
            End Select
     
        End With
SkipRow:
    Next iRow

[p45cal]

Regarding the error; take a look at the very bottom of your Weekly_Research sheet. There's data there which I'm guessing is put there by a previous run of your macro.
The error comes from one of the lines which reads:
ActiveCell.End(xlDown).Activate
putting the activecell at the bottom of the sheet, then when next:
ActiveCell.Offset(1, 0).Activate
gets executed it's trying to activate a non-existent cell (beyond the bottom of ther sheet). This causes the error.

In the attached is this code which you can run:

Sub blah()
Dim logid As Long, opendate As String, issrcgnz As String, Destn As Range, WRrowcount As Long, myRng As Range, CritRng As Range, Cll As Range, issuetype As String, status As String, RecommendedAction As String, action As String, analysis As String
  RestoreWeekly_ResearchSheet 'only used in development - delete this line and the macro it calls.
  logid = 5
  opendate = "February 26th, 2016"
  issrcgnz = "Weekly Workbooks"
  Set Destn = Sheets("MassUpload_Print").Cells(2, 1) 'might need to clear destination area here? See next line.
  Sheets("MassUpload_Print").Cells.Clear 'clears the whole sheet.
  With Sheets("Weekly_Research")
    WRrowcount = .Range("C1").CurrentRegion.Rows.Count
    Set myRng = .Range("A1:N" & WRrowcount)
    
'    Set CritRng = .Range("R1:R6")
'    CritRng.Value = [{"Action";"RH*";"HR*";"Co*";"Im*";"AR*"}]
    Set CritRng = .Range("R1:R12")
    CritRng.Value = [{"Action";"RH*";"HR*";"Co*";"Im*";"AR*";"*Packaging Issue*";"*Defective Item*";"*Received Wrong Item*";"*Missing Parts*";"*Copy Issue*";"*Image Issue*"}]
    
    myRng.AdvancedFilter action:=xlFilterInPlace, CriteriaRange:=CritRng, Unique:=False
    For Each Cll In myRng.Columns(6).Offset(1).Resize(myRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Cells
      issuetype = Empty: status = Empty: RecommendedAction = Empty: action = Empty: analysis = Empty
      'Cll.Select
      analysis = Cll.Offset(, 1).Value 'is this in the right place?
      Select Case Left(Cll.Value, 2)
        Case "AR"
          issuetype = "At Risk"
          status = "Open"
        Case "HR"
          issuetype = "High Risk"
          status = "Open"
        Case "RH"
          issuetype = "Return Hold Report"
          status = "Return Hold"
        Case "Co", "Im"
          issuetype = "Item Enhancement"
          status = "Open"
      End Select
      Select Case True
        Case InStr(1, Cll.Value, "Packaging Issue", vbTextCompare) > 0
          RecommendedAction = "Please review and update packaging of this product.  Please send images of packaging improvements or a new drop test report."
          action = "Packaging Issue"
        Case InStr(1, Cll.Value, "Defective Item", vbTextCompare) > 0
          RecommendedAction = "Please perform inventory check to remove defective product.  Please advise once this has been done."
          action = "Defective Item"
        Case InStr(1, Cll.Value, "Received Wrong Item", vbTextCompare) > 0
          RecommendedAction = "Please check UPCs to ensure that they match Overstock SKU number(s).  Please check inventory to ensure that product is labeled correctly."
          action = "Received Wrong Item"
        Case InStr(1, Cll.Value, "Missing Parts", vbTextCompare) > 0
          RecommendedAction = "Please perform inventory check to ensure that product arrives complete.  Please advise once this has been done."
          action = "Missing Parts"
        Case InStr(1, Cll.Value, "Copy Issue", vbTextCompare) > 0, InStr(1, Cll.Value, "Image Issue", vbTextCompare) > 0
          RecommendedAction = analysis 'has it been assigned yet? pd.
      End Select
      Cll.Value = action
      Cll.Offset(, -2).Value = issuetype
      Cll.Offset(, -1).Value = status
      Cll.Offset(, 2).Value = RecommendedAction

      Destn.Resize(, 12).Value = Array(logid, opendate, Cll.Offset(, -3).Value, status, issuetype, Cll.Offset(, 6).Value, issrcgnz, action, Cll.Offset(, 1).Value, RecommendedAction, Cll.Offset(0, 8).Value, Cll.Offset(0, 7).Value)
      Set Destn = Destn.Offset(1)
    Next Cll
    'undo advanced filter, erase criteria range:
    .ShowAllData
    CritRng.ClearContents
  End With
End Sub

Sub RestoreWeekly_ResearchSheet()
  Application.DisplayAlerts = False
  Sheets("Weekly_Research").Delete
  Application.DisplayAlerts = True
  Sheets("Weekly_Research (2)").Copy Before:=Sheets(1)
  Sheets("Weekly_Research (3)").Name = "Weekly_Research"
End Sub

It might just do what you want but there are small differences which probably won't matter. One is if you have a cell with AR: Defective Goods, you'll see that there is the word Good in there. Your code would skip over this, mine doesn't.
There some comments within the code.

One thing I'm not sure of is the whether the likes of Packaging Issue, Missing Parts, Copy Issue have to be with one of RH, HR, Co, Im, AR at the start or not. Your existing code suggests not. The problem is that we haven't got a wide range of possibilities in that column in your sample file.