Consulting

Results 1 to 3 of 3

Thread: VBA - help optimise/clean up the code

  1. #1
    VBAX Newbie
    Joined
    Dec 2018
    Posts
    3
    Location

    VBA - help optimise/clean up the code

    Hi,

    I'm new to VBA but not new to programming. Because I have some experience with other languages I can see that my code is far from good. There's a lot of duplication. I put it together by copy/pasting from online sources and/or googling some specific commands.

    Would someone be able to help make it more concise or optimised:

    Sub ValidateReturn()
        DeleteFirstSheet
        CreateSheet
        CopyAims
        FillBlanks
        SplitLearnerDetails
       End Sub
    
    Sub SplitLearnerDetails()
    Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
    tw.Activate
    Range("A1").EntireColumn.Insert Shift:=xlToRight
    Range("A1").EntireColumn.Insert Shift:=xlToRight
    Range("A1").EntireColumn.Insert Shift:=xlToRight
    Dim substrings() As String
    Dim i As Long
    lRow = Cells(Rows.Count, 4).End(xlUp).Row
    For i = 1 To lRow
            substrings = Split(Cells(i, 4), " - ")
            Cells(i, 1).Value = substrings(0) & "-" & Cells(i, 5)
            Cells(i, 2).Value = substrings(0)
            Cells(i, 3).Value = substrings(1)
    Next i
    End Sub
    
    Sub FillBlanks()
    Dim lRow As Long
    Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
    tw.Activate
    'Find the last non-blank cell in column A(1)
    'I think this needs to be changed to 1 below as we re not inserting it yet
    lRow = Cells(Rows.Count, 2).End(xlUp).Row
    'Iterate over Column A values
    'If it's blank, take the value from the cell above
    For i = 1 To lRow
    If Cells(i, 1).Value = "" Then
    Cells(i, 1).Value = Cells(i - 1, 1).Value
    End If
    Next i
    End Sub
    
    Sub CopyHeader()
    Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") 'source worksheet
    Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
    tw.Activate
    'insert a blank row
    tw.Range("A1").EntireRow.Insert
    sw.Activate
    Const WHAT_TO_FIND As String = "Learner"
    Set FoundCell = sw.Range("A:A").Find(What:=WHAT_TO_FIND)
    If Not FoundCell Is Nothing Then
    sw.Rows(FoundCell.Row).EntireRow.Copy tw.Range("A1")
    Else
    MsgBox (WHAT_TO_FIND & " not found")
    End If
    End Sub
    
    Sub DeleteFirstSheet()
    'Check if the first sheet is called Sheet1
    'If so, delete it.
    Dim t As String
    t = Sheets(1).Name
    If t = "Sheet1" Then
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
    End If
    Sheets(1).Name = "OriginalFunding"
    End Sub
    
    Private Sub CreateSheet()
    Dim ws As Worksheet
    With ThisWorkbook
    Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    ws.Name = "FundingReturn"
    End With
    End Sub
    
    
    Sub CopyAims()
        Dim i As Long
        Dim vLastRow As Long
        Dim s2 As Long
        Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") '<-- Update
        Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") '<-- Update
        'Activate the source sheet
        sw.Activate
        'find last row in sheet, or you could change to find last row in specified column
        'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
        vLastRow = Cells.Find(What:="*", After:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        s2 = 1
        Application.ScreenUpdating = False
        For i = 1 To vLastRow
            If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
                Rows(i).EntireRow.Copy Destination:=tw.Range(Cells(s2, 1).Address)
                s2 = s2 + 1
            End If
        Next i
        Application.ScreenUpdating = True
       End Sub


    Thank you
    Last edited by Aussiebear; 12-25-2018 at 07:33 AM. Reason: Cleaned up code presentation

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Suggestions / personal style comments -- didn't test or check your logic

    1. Use Option Explicit to require variable declaration

    2. It seems that sw and tw should be declared at the module level and would be available to all procedures within that module

    3. Since ValidateReturn() seems to be the main user-called sub, I prefer to put 'top level' code there, like ScreenUpdating and the Set's for global variables
    4. The other subs appear to be not user callable, so making them Private will keep them off the Run Macros lists

    5. Usually, it's not necessary to select an object to act on it

    6. I personally avoid letting methods or properties default to (say) the Activesheet

    So instead of just Cells(I,2).Value I use something like tw.Cells(I, 2).Value

    Many times I've had a hard to track down bug, because a different sheet was active than the one I thought was

    7. You can use With / End With to simplify the code

    8. My style is to not put multiple statements on one line (e.g. Dim …. : Set …..). I find that harder to debug when stepping through a macro. Likewise I like to Dim all my variables in one place at the top

    9. Finally, as you get more VBA experience, become familiar with the Excel object model so that you don't write a long complicated macro that the right call to the right Excel object can do easier and faster


    This is just markup of the main and one supporting sub to show what I'm trying to say. I thought your macros were pretty good.

    Option Explicit
    
    'module level
    Dim sw As Worksheet 'source worksheet
    Dim tw As Worksheet 'target worksheet
    
    Sub ValidateReturn()
        
        Application.ScreenUpdating = False
        
        Set sw = ThisWorkbook.Sheets("OriginalFunding") 'source worksheet
        Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
        
        DeleteFirstSheet
        CreateSheet
        CopyAims
        FillBlanks
        SplitLearnerDetails
        
        Application.ScreenUpdating = True
    End Sub
    
    
    
    Private Sub SplitLearnerDetails()
        Dim substrings() As String
        Dim i As Long, lrow As Long
    '    tw.Activate ' not required
        With tw
            .Range("A1").EntireColumn.Insert Shift:=xlToRight
            .Range("A1").EntireColumn.Insert Shift:=xlToRight
            .Range("A1").EntireColumn.Insert Shift:=xlToRight
            lrow = .Cells(.Rows.Count, 4).End(xlUp).Row
            For i = 1 To lrow
                substrings = Split(.Cells(i, 4), " - ")
                .Cells(i, 1).Value = substrings(0) & "-" & Cells(i, 5)
                .Cells(i, 2).Value = substrings(0)
                .Cells(i, 3).Value = substrings(1)
            Next i
        End With
        
    End Sub
    Last edited by Paul_Hossler; 12-27-2018 at 06:52 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Newbie
    Joined
    Dec 2018
    Posts
    3
    Location
    Thank you very much. Much appreciated. Your feedback is very helpful. I'll go through it in detail and post if I have any further questions.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •