VBA cleanup

**paul_j_** · 06-09-2015, 02:07 AM

Hi
I had a query in the Excel General area and have come up with an solution that works reasonably well with some basic VBA coding.
Is this coding OKAY or can it be tidied up a bit ?

I would like to think I was on the right path in coding this.

Here is the original posting....

http://www.excelforum.com/excel-gene...match-vba.html

**SamT** · 06-09-2015, 03:39 AM

Let us assume for the sake of argument that you are referring to the code i post #8. Then no I can't clear it up because it is not the entire procedure.

Post the whole thing here, from Sub to End sub, inclusive.

**romperstomper** · 06-09-2015, 04:05 AM

First, you don't need a colon at the end of every line!

Second, avoid selecting things - it's unnecessary 99.86% of the time.

Third, always specify the property you want - even .Value

Untested:

    Dim wsAN                        As Excel.Worksheet

    R_COUNT = Worksheets("AN XML").Cells(1, 4).Value    ' count occupied rows

    '---------------------------------------------
    For Cycle = 1 To 6    ' Do 6 SORT passes to capture 6 identical multi entries (change this if more is req'd) (LIKE data types for comparison)
        Set wsAN = Sheets("AN SOURCE")
        With wsAN
            With .Sort
                With .SortFields
                    .Clear
                    .Add Key:=wsAN.Range(wsAN.Cells(3, 1), wsAN.Cells(R_COUNT, 1)), SortOn:=xlSortOnValues, _
                         Order:=xlAscending, DataOption:=xlSortNormal
                    .Add Key:=wsAN.Range(wsAN.Cells(3, 6), wsAN.Cells(R_COUNT, 6)), SortOn:=xlSortOnValues, _
                         Order:=xlAscending, DataOption:=xlSortNormal
                    .Add Key:=wsAN.Range(wsAN.Cells(3, 5), wsAN.Cells(R_COUNT, 5)), SortOn:=xlSortOnValues, _
                         Order:=xlAscending, DataOption:=xlSortNormal
                End With
                .SetRange wsAN.Range(wsAN.Cells(3, 1), wsAN.Cells(R_COUNT, 25))
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            '====================================
            For R_COUNTER = 3 To R_COUNT    ' count from row 3 to last occupied row

                R_STRNG = ""    'Null out any legacy data
                R_STRNG = Right(.Cells(R_COUNTER, 5).Value, 4)    'Assigns new data - Returns .xls, xlsm, .pdf etc

                EX_STRNG = ""    'Null out any legacy data
                EX_STRNG = (.Cells(R_COUNTER, 6).Value)    'Returns EXIST string

                NEW_STRNG = ""    'Null out any legacy data
                NEW_STRNG = EX_STRNG & " " & R_STRNG    'Create NEW string

                FLAGGED = ""
                If (.Cells(R_COUNTER, 1).Value) = (.Cells(R_COUNTER - 1, 1).Value) And (.Cells(R_COUNTER, 6).Value) = (.Cells(R_COUNTER - 1, 6).Value) Then FLAGGED = "WRITE"
                If FLAGGED = "WRITE" Then .Cells(3, 1).Offset(R_COUNTER - 3, 5) = NEW_STRNG
            Next R_COUNTER
            '====================================
        Next Cycle
    End With

I am not suggesting this is the most efficient way of achieving your ends, just amending the existing code.

**SamT** · 06-09-2015, 05:25 AM

A picture may be worth a thousand words but a workbook is worth a thousand pictures!

Can I steal that? I'll credit you.

**romperstomper** · 06-09-2015, 05:43 AM

Feel free.

**TMS** · 06-09-2015, 06:21 AM

Maybe this:

Option Explicit

Sub sModifyColumnA()

Dim lLR As Long, i As Long
Dim sString As String
Dim vArray

lLR = Range("A" & Rows.Count).End(xlUp).Row
ReDim vArray(1 To lLR)

For i = 1 To lLR
    sString = "=IF($A" & i & "="""","""",COUNTIFS($A$2:$A" & i & ",$A" & i & ",$F$2:$F" & i & ",$F" & i & "))"
    If Evaluate(sString) = "" Then
        vArray(i) = ""
    Else
        vArray(i) = IIf((Evaluate(sString)) > 1, Range("A" & i).Value & "-" & Evaluate(sString), Range("A" & i).Value)
    End If
Next 'i

Application.ScreenUpdating = False
Range("A1").Resize(lLR, 1) = Application.Transpose(vArray)
Application.ScreenUpdating = True

End Sub

Regards, TMS