make shorter

[beastman59]

Thanks to those that helpped in two of the parts of the following. I thought I would show the complete code. I was wondering if there is some way to do all this and be shorter. Thanks in advance.

' =========================GET LOGGED IN USER============================================
     ' Declare for call to mpr.dll.
   Declare Function WNetGetUser Lib "mpr.dll" _
      Alias "WNetGetUserA" (ByVal lpName As String, _
      ByVal lpUserName As String, lpnLength As Long) As Long
   Const NoError = 0       'The Function call was successful
Sub TEXAS()
    ' Buffer size for the return string.
    Const lpnLength As Integer = 255
    ' Get return buffer space.
    Dim status As Integer
    ' For getting user information.
    Dim lpName, lpUserName As String
    ' Assign the buffer size constant to lpUserName.
    lpUserName = Space$(lpnLength + 1)
    ' Get the log-on name of the person using product.
    status = WNetGetUser(lpName, lpUserName, lpnLength)
    ' See whether error occurred.
    If status = NoError Then
    ' This line removes the null character. Strings in C are null-
    ' terminated. Strings in Visual Basic are not null-terminated.
    ' The null character must be removed from the C strings to be used
    ' cleanly in Visual Basic.
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
        Else
    ' An error occurred.
        MsgBox "Unable to get the name."
        End
    End If
    Dim I As Integer
    Dim Pos As Integer
    Dim FindChar As String
    Dim SearchString As String
'============================CONVERT TO UPPER CASE,REMOVE "COUNTY"==============================='
    For A = 1 To 254                                      'TEXAS HAS 254 COUNTIES
         R = "D" & A
         j = "a" & A
         C = "c" & A
         SearchString = Sheet1.Range(j)
         FindChar = " "
         For I = 1 To Len(SearchString)
             If Mid(SearchString, I, 1) = FindChar Then Pos = I
         Next I
         Sheet1.Range(R) = UCase(Left$(SearchString, Pos))
         Sheet1.Range(C) = A
    Next A
'======================PUT THE COUNTIES IN A LARGE STRING SEPERATED WITH A COMMA==============='
    For A = 1 To 254                                        'TEXAS HAS 254 COUNTIES
        R = "D" & A
        If A > 1 Then
            Sheet1.Range("a256") = Trim(Sheet1.Range("a256")) & "," & Sheet1.Range(R)
        Else
           Sheet1.Range("a256") = Trim(Sheet1.Range(R))
        End If
    Next A
'==========================CREATE THE TXT FILE================================================='
    THEFILENAME = "C:\Users\" & lpUserName & "\Desktop\Texas-counties.txt"
    Open THEFILENAME For Output As #1
    Print #1, Sheet1.Range("A256")
    Close #1
'===========================CALCULATE AND PRINT AIR ACCOUNT LETTERS============================'
    lR = 254                                                'TEXAS HAS 254 COUNTIES
    oRws = 0
    Set R = Range("A" & oRws + 1, "A" & lR)
    vA = R.Value
    For I = LBound(vA, 1) To UBound(vA, 1)
        If I = 1 Then
            Cells(I + oRws, 5).Value = Left(Trim(CStr(vA(I, 1))), 1) & Chr(65 + N)
        Else
            If N = 25 Then N = -17            'Z ALREADY USED, SO USING 1 (65-17=48 WHICH IS 1
            N = N + 1
            If Left(Trim(CStr(vA(I, 1))), 1) = Left(Trim(CStr(vA(I - 1, 1))), 1) Then
               Cells(I + oRws, 5).Value = Left(Trim(CStr(vA(I, 1))), 1) & Chr(65 + N)
            Else
                N = 0
                Cells(I + oRws, 5).Value = Left(Trim(CStr(vA(I, 1))), 1) & Chr(65 + N)
            End If
       End If
    Next I
'============================GET THE TCEQ REGIONS==============================================='
    For A = 1 To 254                                        'TEXAS HAS 254 COUNTIES
        R = "F" & A
        j = "i" & A
        SearchString = Sheet1.Range(j)
        FindReg = "Region "
        For I = 1 To Len(SearchString)
            If Mid(SearchString, I, 7) = FindReg Then Pos = I + 8
        Next I
        If Mid$(SearchString, Pos, 1) = "," Then
            Sheet1.Range(R) = Mid$(SearchString, Pos - 1, 1)
        Else
            Sheet1.Range(R) = Mid$(SearchString, Pos - 1, 2)
        End If
    Next A
'=======================CREATE SHEET 2 USING INFORMATION FROM SHEET 1=========================='
    Sheet2.Cells.Clear                                  'CLEAR SHEET2 BEFORE BEGINNING
    Sheet2.Range("A1:A52,E1:E52").NumberFormat = "000"  'COUNTY IS THREE DIGITS
    Sheet2.Range("D1:D52,H1:H52,L1:L52,P1:P52,T1:T52").NumberFormat = "000" 'REGION IS 3 DIGITS
    NUM = 65                                            'A=65 - GOING TO CHANGE LETTERS
    NAM = 66
    AIR = 67
    REG = 68
    THEROW = 1
    For A = 1 To 254                                    'TEXAS HAS 254 COUNTIES
        Select Case A
            Case 52, 103, 154, 205              'IF A = THOSE NUMBERS PUT IN NEXT COLUMN ROW 1
                THEROW = 1
                NUM = NUM + 4
                NAM = NAM + 4
                AIR = AIR + 4
                REG = REG + 4
        End Select
        C = "C" & A
        D = "D" & A
        E = "E" & A
        F = "F" & A
        OA = Chr(NUM) & THEROW
        OB = Chr(NAM) & THEROW
        OC = Chr(AIR) & THEROW
        OD = Chr(REG) & THEROW
        Sheet2.Range(OA) = Sheet1.Range(C)
        Sheet2.Range(OB) = Sheet1.Range(D)
        Sheet2.Range(OC) = Sheet1.Range(E)
        Sheet2.Range(OD) = Sheet1.Range(F)
        THEROW = THEROW + 1
    Next A
'=============================INSERT ROW AND PUT COLUMN HEADINGS=============================='
    Sheet2.Range("A1").EntireRow.Offset(0, 0).Insert
    NUM = 65
    NAM = 66
    AIR = 67
    REG = 68
    For A = 1 To 5                                      '5 COLUMNS WITH SAME HEADINGS
         OA = Chr(NUM) & 1
         OB = Chr(NAM) & 1
         OC = Chr(AIR) & 1
         OD = Chr(REG) & 1
         Sheet2.Range(OA) = "NUM"
         Sheet2.Range(OB) = "NAME"
         Sheet2.Range(OC) = "AIR"
         Sheet2.Range(OD) = "REGION"
         NUM = NUM + 4
         NAM = NAM + 4
         AIR = AIR + 4
         REG = REG + 4
    Next A
'=======================================SET FONT AND SIZE======================================'
    Sheet2.Activate                              'ACTIVATE SHEET2
    Sheet2.Range("A1:T254").Select               'SELECT RANGE TO FORMAT - WHERE EVERYTHING TO PRINT IS
    With Selection.Font
         .name = "Arial"
         .Size = 13
         .ColorIndex = 1
    End With
'====================DIFFERENT COLOR FOR EACH COLUMN AND AUTO WIDTH============================'
    THECOL = 65                                'START WITH COLUMN A
    For A = 1 To 20
        Sheet2.Columns(Chr(THECOL)).Select     'SELECT COLUMN FOR COLOR
        With Selection.Font
            Select Case A
               Case 1, 5, 9, 13, 17, 21        'COUNTY NUMBER
                   .ColorIndex = 1
               Case 2, 6, 10, 14, 18, 22       'COUNTY NAME
                   .ColorIndex = 7
               Case 3, 7, 11, 15, 19, 23       'AIR ACCOUNT
                   .ColorIndex = 5
               Case 4, 8, 12, 16, 20, 24       'REGION
                   .ColorIndex = 3
            End Select
        End With
        Sheet2.Columns(Chr(THECOL)).AutoFit
        THECOL = THECOL + 1
    Next A
'=====================PUT VERTICLE SEPERATOR LINES BETWEEN THE FIVE GROUPS AND CENTER=========='
    Sheet2.Range("D1:D52,H1:H52,L1:L52,P1:P52,T1:T52").Borders(xlEdgeRight).Weight = xlThick
    Sheet2.Range("A52:T52").Borders(xlEdgeBottom).Weight = xlThick
    Sheet2.Range("A1:T1").Borders(xlEdgeTop).Weight = xlThick
    Sheet2.Range("A1:T1").Borders(xlEdgeBottom).Weight = xlThick
    Sheet2.Range("A1:A52").Borders(xlEdgeLeft).Weight = xlThick
    Sheet2.Range("A1:T52").HorizontalAlignment = xlCenter
'==================FIT TO ONE PAGE, PRINT GRIDLINES, SET PRINT AREA, LANDSCAPE================='
    MYDATE = Format$(Now(), "M/D/YYYY")                       'STORES CURRENT DATE AS STRING
    With Sheet2.PageSetup
       .Zoom = False
       .FitToPagesWide = 1
       .FitToPagesTall = 1
       .PrintArea = "A1:T52"
       .PrintGridlines = True
       .CenterHeader = "TCEQ COUNTY NUMBERS, COUNTY NAMES, AIR ACCOUNTS, AND REGIONS"
       .CenterFooter = "PRINTED ON " & MYDATE
       .Orientation = xlLandscape
    End With
'=========SEE IF WANT TO PRINT, IF YES THEN SELECT PRINTER AND PRINT============================'
    ANS = MsgBox("Do you want to print the county, air account, and region list", vbYesNo)
    If ANS = vbYes Then
       Application.Dialogs(xlDialogPrinterSetup).Show   'SHOWS ALL PRINTERS - DOUBLE CLICK ONE
       Sheet2.PrintOut                                  'PRINTS SHEET2 ON PRINTER SELECTED
    End If
End Sub

 

[nuked]

By 'shorter', I pressume you mean fewer lines of code? Or perhaps you mean 'work quicker'?

Please clarify.

 

[beastman59]

Fewer lines of code. It used to be longer but I moved some lines of code and made it a little shorter. I don't like more than 1 statement per line and I want the comments to remain since I just started learning VBA.

 

[Jonmo1]

Does it work?

Shorter is not necessarily Better
If it ain't broke, don't fix it

 

[beastman59]

I agree with you...really it is only going to be used once (unless someone wants different colors or columns in different order) which both would be easy to change. I tried using everything I could think of...getting logged in user name, writting to text file, drop down box for printer choice, searching strings. I'm just starting to learn VBA and will refer back to this. I don't claim script writting on my resume, but if there is something I want done, I can usually get it done...even if it means googling or this forum.

Again I want to thank those that helpped with various sections of it.