Code advice - What would you change?

[JamesW]

Hey guys,

Thought I'd post a little something I've been working on. I'd like to know what things people would do differently if they could change anything.

Don't laugh when you see it, I'm still very delicate from last night with Jon Von and Mike...

Always up for constructive criticism, and I am always looking to learn new things.

Option Explicit
Dim lRow, NPILRow, i, j, n As Integer
Dim FileToOpen As String
Dim MyBook, ThisWB As Workbook
Dim cell As Variant
Dim fileNCheck As VbMsgBoxResult

Sub Main()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Set ThisWB = ThisWorkbook
    
    NPILRow = Range("C" & Rows.Count).End(xlUp).Row
    Range("S8:S" & NPILRow).Copy Destination:=Range("R8:R" & NPILRow)
    
    FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose the latest xxx file", _
    FileFilter:="Excel Files *.xls (*.xls),")
    
    If FileToOpen = "False" Then
        MsgBox "No file specified."
        Exit Sub
    Else
        If Not FileToOpen Like "*xxx*" Then
            fileNCheck = MsgBox(FileToOpen & " is not a recognised file/filename.  Please ensure that you are using an APO file. " & vbNewLine & vbNewLine & "Do you wish to continue regardless? Doing so may produce incorrect results", vbYesNo)
            If fileNCheck = vbNo Then
                Exit Sub
            End If
        End If
        Set MyBook = Workbooks.Open(Filename:=FileToOpen)
    End If

    With MyBook.Sheets("Sheet1")
        lRow = .Range("AL" & Rows.Count).End(xlUp).Row
        For i = 2 To lRow
            For j = 38 To 193
                If .Cells(i, j).Value <> 0 Then
                    If j = 38 Then
                        .Range("AK" & i).Value = "From Now"
                        Exit For
                    Else
                        .Range("AK" & i).Value = Cells(1, j).Value
                        Exit For
                    End If
                Else
                    .Range("AK" & i).Value = "No FC"
                End If
            Next j
        Next i
    End With
    
    With ThisWB.Sheets("SKU Completed")
        .Range("S8").Value = "=VLOOKUP(RC[-16],'" & FileToOpen & "'!C1:C37,37,FALSE)"
        .Range("S8").AutoFill (.Range("S8:S" & NPILRow))
        .Range("T8").Value = "=IF(OR(RC[-1]=""No FC"",RC[-1]=""From Now""),""Unknown"",IF(and(MID(RC[-1],FIND(""."",RC[-1],1)+1,(FIND(""."",RC[-1],3)-FIND(""."",RC[-1],1)-1))+0-RC[-4]<=1,MID(RC[-1],FIND(""."",RC[-1],1)+1,(FIND(""."",RC[-1],3)-FIND(""."",RC[-1],1)-1))+0-RC[-4]>=-1),""OK"",""Issue""))"
        .Range("T8").AutoFill (.Range("T8:T" & NPILRow))
    End With
    
    ThisWB.Activate
    MyBook.Close SaveChanges:=True
    
    Range("S8:T" & NPILRow).Copy
    Range("S8:T" & NPILRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Cheers,

James

 

[ZVI]

ZVI, you've totally lost me now!

Don't mind, James!
It's not discord - just another side and confirmation of the rules.
In spite of it’s already fixed by you, below is my commenting of post#6 code:

Sub Main()
  Dim lRow As Variant, NPILRow As Variant, i As Variant, j As Variant, n As Variant
  Dim FileToOpen As String
  ' In the line below MyBook was absent, typo is fixed
  Dim MyBook As Workbook, ThisWB As Workbook
  Dim cell As Range
  Dim fileNCheck As VbMsgBoxResult
  Dim OldSelection As Range     ' <-- Added to save/restore old selection

  With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
  End With

  Set ThisWB = ThisWorkbook
  
  ' --> Added
  ThisWB.Activate               ' <-- For the case it's not active
  Sheets("Sheet1").Activate     ' <-- Change "Sheet1" to actual sheet's name
  Set OldSelection = Selection  ' <-- Save old selection to restore it later
  ' <-- End of adding
  

  NPILRow = Range("C" & Rows.Count).End(xlUp).Row
  Range("S8:S" & NPILRow).Copy Destination:=Range("R8:R" & NPILRow)

  FileToOpen = Application.GetOpenFilename _
               (Title:="Please choose the latest APO file", _
                FileFilter:="Excel Files *.xls (*.xls),")

  If FileToOpen = "False" Then
    MsgBox "No file specified."
    'Exit Sub         ' Exit Sub is not good because Calculation and ScreenUpdating are not restored.
                      ' GoTo exitLabel can be used here, but don't say it to Rory!
                      ' Or add here the restoring of Calculation and ScreenUpdating statuses.
                      ' Or restruct the code to exclude GoTo,
                      ' calling separate functions for that can be used as well.
    GoTo exitLabel    ' <-- Added (see warnings in the comments above)
  Else
    If Not FileToOpen Like "*APO*" Then
      fileNCheck = MsgBox(FileToOpen & " is not a recognised file/filename.  Please ensure that you are using an APO file. " & vbNewLine & vbNewLine & "Do you wish to continue regardless? Doing so may produce incorrect results", vbYesNo)
      If fileNCheck = vbNo Then
        GoTo exitLabel  ' See the comments above
      End If
    End If
    Set MyBook = Workbooks.Open(Filename:=FileToOpen)
  End If

  ' If this part is slow then copy range into array for fast processing
  With MyBook.Sheets("Sheet1")
    lRow = .Range("AL" & Rows.Count).End(xlUp).Row
    For i = 2 To lRow
      For j = 38 To 193
        If .Cells(i, j).Value <> 0 Then
          If j = 38 Then
            .Range("AK" & i).Value = "From Now"
            Exit For
          Else
            .Range("AK" & i).Value = Cells(1, j).Value
            Exit For
          End If
        Else
          ' Not sure, but seems it's playing too many times.
          ' If so then add checking of "already done" flag to skip repeating
          .Range("AK" & i).Value = "No FC"
        End If
      Next j
    Next i
  End With

  With ThisWB.Sheets("SKU Completed")
    ' In line below .Formula looks more clear than .Value - see the Rory's "Don't use Value if you are assigning a formula"
    .Range("S8").Formula = "=VLOOKUP(RC[-16],'" & FileToOpen & "'!C1:C37,37,FALSE)"
    ' Parenthesis around (.Range("S8:S" & NPILRow)) are deleted according to Rory's comment
    .Range("S8").AutoFill .Range("S8:S" & NPILRow)
    ' Use .Formula instead of .Value here - see the comment two code lines above,
    .Range("T8").Formula = "=IF(OR(RC[-1]=""No FC"",RC[-1]=""From Now""),""Unknown"",IF(and(MID(RC[-1],FIND(""."",RC[-1],1)+1,(FIND(""."",RC[-1],3)-FIND(""."",RC[-1],1)-1))+0-RC[-4]<=1,MID(RC[-1],FIND(""."",RC[-1],1)+1,(FIND(""."",RC[-1],3)-FIND(""."",RC[-1],1)-1))+0-RC[-4]>=-1),""OK"",""Issue""))"
    ' Parenthesis around (.Range("T8:T" & NPILRow)) are deleted
    .Range("T8").AutoFill .Range("T8:T" & NPILRow)
  End With

  ThisWB.Activate
  MyBook.Close SaveChanges:=True

  Range("S8:T" & NPILRow).Copy
  Range("S8:T" & NPILRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
  
exitLabel:
  OldSelection.Select     ' <-- Added to reset old selection
  With Application
    .CutCopyMode = False  ' <-- Added to switch copy mode off
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With

End Sub

Regards,
Vlad

 

[JamesW]

Cheers Vlad.

I have already made most of the changes in my second take of the code I posted, but I will add the bits at the top.

Next step is to work on the FOR loops I guess

 

[ZVI]

Next step is to work on the FOR loops I guess

Ok, try this:

  ' For-Next part of code
  Const AL& = 38, GK& = 193
  Dim RngAK As Range, ArrAK(), ArrRow, ArrTitl
  With MyBook.Sheets("Sheet1")
    ' Disable autofilter if set for correct lRow calculating
    If .FilterMode Then .ShowAllData
    ' Copy AL1:GK1 titles to ArrTitl() array
    ArrTitl = .Range("AL1:GK1").Value
    ' Replace 1st value of ArrTitl() by "From Now"
    ArrTitl(1, 1) = "From Now"
    ' Calc last row in AK column
    lRow = .Range("AL" & .Rows.Count).End(xlUp).Row
    ' Set AK range
    Set RngAK = .Range("AK2:AK" & lRow)
    ' Prepare array for output AK values
    ReDim ArrAK(1 To RngAK.Rows.Count, 1 To 1)
    ' Loop through the rows
    For i = 1 To UBound(ArrAK)
      ' Copy the current row's values into array to accelerate processing
      ArrRow = .Range(.Cells(i + 1, AL), .Cells(i + 1, GK)).Value
      ' Set default value for output array ArrAK()
      ArrAK(i, 1) = "No FC"
      ' Loop through columns of the row
      For j = 1 To UBound(ArrRow, 2)
        If ArrRow(1, j) <> 0 Then
          ' Copy title of the 1st non-zero column into ArrAK()
          ArrAK(i, 1) = ArrTitl(1, j)
          Exit For
        End If
      Next
    Next
    ' Copy value from array ArrAK() to destination column AK
    RngAK.Value = ArrAK
  End With
  

Only single row is copied into array because maximum rows in AL:GK range is unknown for me (if it's about million?).
Hope that the code is fast enough now.

Regards,
Vlad