+ Reply to Thread
Results 1 to 8 of 8

Macro based on header search

Hybrid View

  1. #1
    Registered User
    Join Date
    10-13-2011
    Location
    OKC
    MS-Off Ver
    Excel 2007
    Posts
    5

    Smile Macro based on header search

    I need a macro to run that will save Zip and Zip+4 in a certain format (00000 and 0000 respectively). The issue is that I have about 8 different files this macro needs to run on and the Zip and Zip+4 field is not in the same location every time. I know how to do the macro to run the formatting, I now need a macro that will search every cell in the first row and when it finds ZIP will format as needed (00000) and when it finds ZIP+4 will format as needed (0000). In addition to this, the field does not have common naming, sometimes it will simply be ZIP or Zip+4 but other times it will be CompanyZip and CompanyZip+4 so the search needs to search the cell contents for a non exact match. It also only needs to search the first row, nothing else.

    It would be good (not needed) if we could also not apply the macro if the column is not populated past the first row. Some projects have multiple fields that will hold zip but not all projects will have that info populated.

    This code will be part of existing code that is used to save each file as pipe (|) delimited so it does not need to be stand alone code.

    Any help is greatly appreciated!! Feel free to ask any questions needed.
    Last edited by cardinalsfan0510; 10-13-2011 at 03:22 PM. Reason: Solved!! Thanks Leith!!

  2. #2
    Forum Moderator Leith Ross's Avatar
    Join Date
    01-15-2005
    Location
    San Francisco, Ca
    MS-Off Ver
    2000, 2003, & 2010
    Posts
    23,259

    Re: Macro based on header search

    Hello cardinalsfan0510,

    Welcome to the Forum!

    This macro will open all ".xls" files in the specified folder and check each worksheet's first row for Zip and Zip+4 in the cells values. If there are not at least two rows on the worksheet, the macro will skip the worksheet. You can add this macro to your existing code by copying the code and pasting it into a separate VBA module. You will then need to call this macro from the existing code when needed.

    You will need to change the file path to where your files are located. Currently, the macro searchs for ".xls" workbook files. You can change the extension if needed. Change the variable Ext in the code to the extension you need. Remember to include the period before the extension.

    Sub FormatZipColumns()
    
        Dim Cell As Range
        Dim Ext As String
        Dim Filename As String
        Dim Filepath As String
        Dim Rng As Range
        Dim Wkb As Workbook
        Dim Wks As Worksheet
        
            Filepath = "C:\Documents and Settings\My Documents"
            Ext = ".xls"
            
                Filepath = IIf(Right(Filepath, 1) <> "\", Filepath & "\", Filepath)
                Filename = Dir(Filepath & "*" & Ext)
                
                Do While Filename <> ""
                   Set Wkb = Workbooks.Open(Filepath & Filename)
                       For Each Wks In Wkb.Worksheets
                           Set Rng = Wks.Range("A1", Wks.Cells(1, Wks.UsedRange.Column))
                           If Wks.UsedRange.Rows.Count > 1 Then
                               For Each Cell In Rng
                                   If LCase(Cell) Like "*zip+4*" Then
                                      Cell.EntireColumn.Cells.NumberFormat = "0000"
                                   Else
                                      If LCase(Cell) Like "*zip*" Then
                                         Cell.EntireColumn.Cells.NumberFormat = "00000"
                                      End If
                                   End If
                               Next Cell
                           End If
                       Next Wks
                   Wkb.Close SaveChanges:=True
                Loop
                
    End Sub
    Sincerely,
    Leith Ross

    Remember To Do the Following....

    1. Use code tags. Place [CODE] before the first line of code and [/CODE] after the last line of code.
    2. Thank those who have helped you by clicking the Star below the post.
    3. Please mark your post [SOLVED] if it has been answered satisfactorily.


    Old Scottish Proverb...
    Luathaid gu deanamh maille! (Rushing causes delays!)

  3. #3
    Registered User
    Join Date
    10-13-2011
    Location
    OKC
    MS-Off Ver
    Excel 2007
    Posts
    5

    Re: Macro based on header search

    Thanks Leith!! The files will already be open when I run the macro. The macro saves each file as a pipe delimited file after we have done what we needed to do. We call the macro up manually and run it ourselves. Let me post the code I already have so it can be modified. I just need to change the middle part that right now does formatting based on the location of the cells in this particular project.

    Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean)
    
    Dim WholeLine As String
    Dim FNum As Integer
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    
    Application.ScreenUpdating = False
    On Error GoTo EndMacro:
    FNum = FreeFile
    
    'This is the section that needs to be modified to perform the search
    
    With Selection
        Columns("L:L").Select
        Selection.NumberFormat = "00000"
        Columns("M:M").Select
        Selection.NumberFormat = "0000"
    End With
    
    'End of section that needs to be modified
    
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If
    
    Open FName For Output Access Write As #FNum
    
    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
               CellValue = Cells(RowNdx, ColNdx).text
            End If
            CellValue = Replace(CellValue, vbCrLf, "")
            CellValue = Replace(CellValue, vbCr, "")
            CellValue = Replace(CellValue, vbLf, "")
            'CellValue = UCase(CellValue) (This was causing the upper case issue for .jpg)
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #FNum, WholeLine
    
    Next RowNdx
    
    EndMacro:
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #FNum
    
    End Sub
    
    Public Sub DoTheExport()
    
    Dim FName As Variant
    Dim Sep As String
    
    FName = Application.GetSaveAsFilename()
    If FName = False Then
        MsgBox "You didn't select a file"
        Exit Sub
    End If
    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")
    ExportToTextFile CStr(FName), Sep, MsgBox("Do You Want To Export The Entire Worksheet?", vbYesNo, "Export To Text File") = vbNo
    
    End Sub

    Quote Originally Posted by Leith Ross View Post
    Hello cardinalsfan0510,

    Welcome to the Forum!

    This macro will open all ".xls" files in the specified folder and check each worksheet's first row for Zip and Zip+4 in the cells values. If there are not at least two rows on the worksheet, the macro will skip the worksheet. You can add this macro to your existing code by copying the code and pasting it into a separate VBA module. You will then need to call this macro from the existing code when needed.

    You will need to change the file path to where your files are located. Currently, the macro searchs for ".xls" workbook files. You can change the extension if needed. Change the variable Ext in the code to the extension you need. Remember to include the period before the extension.

    Sub FormatZipColumns()
    
        Dim Cell As Range
        Dim Ext As String
        Dim Filename As String
        Dim Filepath As String
        Dim Rng As Range
        Dim Wkb As Workbook
        Dim Wks As Worksheet
        
            Filepath = "C:\Documents and Settings\My Documents"
            Ext = ".xls"
            
                Filepath = IIf(Right(Filepath, 1) <> "\", Filepath & "\", Filepath)
                Filename = Dir(Filepath & "*" & Ext)
                
                Do While Filename <> ""
                   Set Wkb = Workbooks.Open(Filepath & Filename)
                       For Each Wks In Wkb.Worksheets
                           Set Rng = Wks.Range("A1", Wks.Cells(1, Wks.UsedRange.Column))
                           If Wks.UsedRange.Rows.Count > 1 Then
                               For Each Cell In Rng
                                   If LCase(Cell) Like "*zip+4*" Then
                                      Cell.EntireColumn.Cells.NumberFormat = "0000"
                                   Else
                                      If LCase(Cell) Like "*zip*" Then
                                         Cell.EntireColumn.Cells.NumberFormat = "00000"
                                      End If
                                   End If
                               Next Cell
                           End If
                       Next Wks
                   Wkb.Close SaveChanges:=True
                Loop
                
    End Sub

  4. #4
    Registered User
    Join Date
    10-13-2011
    Location
    OKC
    MS-Off Ver
    Excel 2007
    Posts
    5

    Re: Macro based on header search

    I took your code and modified it and added it to my code but can't get it to work. It goes through the save process (pick location and filename, choose delimiter character) but doesn't save the file or change the format for the cells. Here is what I have:

    Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean)
    
    Dim WholeLine As String
    Dim FNum As Integer
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    Dim Cell As Range
    Dim Ext As String
    Dim Filename As String
    Dim Filepath As String
    Dim Rng As Range
    Dim Wkb As Workbook
    Dim Wks As Worksheet
    
    Application.ScreenUpdating = False
    On Error GoTo EndMacro:
    FNum = FreeFile
    
    Set Rng = Wks.Range("A1", Wks.Cells(1, Wks.UsedRange.Column))
      If Wks.UsedRange.Rows.Count > 1 Then
        For Each Cell In Rng
         If LCase(Cell) Like "*zip4*" Then
         Cell.EntireColumn.Cells.NumberFormat = "0000"
         Else
         If LCase(Cell) Like "*zip*" Then
         Cell.EntireColumn.Cells.NumberFormat = "00000"
         End If
         End If
        Next Cell
      End If
    
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If
    
    Open FName For Output Access Write As #FNum
    
    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
               CellValue = Cells(RowNdx, ColNdx).text
            End If
            CellValue = Replace(CellValue, vbCrLf, "")
            CellValue = Replace(CellValue, vbCr, "")
            CellValue = Replace(CellValue, vbLf, "")
            'CellValue = UCase(CellValue) (This was causing the upper case issue for .jpg)
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #FNum, WholeLine
    
    Next RowNdx
    
    EndMacro:
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #FNum
    
    End Sub
    
    Public Sub DoTheExport()
    
    Dim FName As Variant
    Dim Sep As String
    
    FName = Application.GetSaveAsFilename()
    If FName = False Then
        MsgBox "You didn't select a file"
        Exit Sub
    End If
    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")
    ExportToTextFile CStr(FName), Sep, MsgBox("Do You Want To Export The Entire Worksheet?", vbYesNo, "Export To Text File") = vbNo
    
    End Sub

  5. #5
    Forum Moderator Leith Ross's Avatar
    Join Date
    01-15-2005
    Location
    San Francisco, Ca
    MS-Off Ver
    2000, 2003, & 2010
    Posts
    23,259

    Re: Macro based on header search

    Hello cardinalsfan0510,

    Are these converted files still Excel workbooks or text files?

  6. #6
    Registered User
    Join Date
    10-13-2011
    Location
    OKC
    MS-Off Ver
    Excel 2007
    Posts
    5

    Re: Macro based on header search

    Quote Originally Posted by Leith Ross View Post
    Hello cardinalsfan0510,

    Are these converted files still Excel workbooks or text files?
    The files we open to modify are text files, pipe delimited. We then QA the data there and make any changes needed and run the macro shown previously to save it as a pipe delimited file again.

    But when we edit the data and run the macro, it is open as a workbook.

    EDIT: Here is what I have now. I think it is close. I got rid of a few things and simplified others. I made it only look at the open sheet (will only have one sheet open at a time) and changed the range to check only the first row as far as I need it to go. It will run without errors but will not save the file and the formats for the columns in question do not change.

    Again, thanks for the help. I am sure i am just missing something small. I can upload a copy of the file I am testing with if that will help.

    Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean)
    
    Dim WholeLine As String
    Dim FNum As Integer
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    Dim Cell As Range
    Dim Ext As String
    Dim Filename As String
    Dim Filepath As String
    Dim Rng As Range
    Dim Wkb As Workbook
    Dim Wks As Worksheet
    
    Application.ScreenUpdating = False
    On Error GoTo EndMacro:
    FNum = FreeFile
    
    
    Do While Not IsEmpty(ActiveCell)
      Set Rng = ActiveSheet.Range.Cells(A1, GW1)
           For Each Cell In Rng
                If LCase(Cell) Like "*zip4*" Then
                Cell.EntireColumn.Cells.NumberFormat = "0000"
                Else
                If LCase(Cell) Like "*zip*" Then
                Cell.EntireColumn.Cells.NumberFormat = "00000"
           End If
           End If
           Next Cell
    Loop
    
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If
    
    Open FName For Output Access Write As #FNum
    
    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
               CellValue = Cells(RowNdx, ColNdx).text
            End If
            CellValue = Replace(CellValue, vbCrLf, "")
            CellValue = Replace(CellValue, vbCr, "")
            CellValue = Replace(CellValue, vbLf, "")
            'CellValue = UCase(CellValue) (This was causing the upper case issue for .jpg)
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #FNum, WholeLine
    
    Next RowNdx
    
    EndMacro:
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #FNum
    
    End Sub
    
    Public Sub DoTheExport()
    
    Dim FName As Variant
    Dim Sep As String
    
    FName = Application.GetSaveAsFilename()
    If FName = False Then
        MsgBox "You didn't select a file"
        Exit Sub
    End If
    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")
    ExportToTextFile CStr(FName), Sep, MsgBox("Do You Want To Export The Entire Worksheet?", vbYesNo, "Export To Text File") = vbNo
    
    End Sub
    Last edited by cardinalsfan0510; 10-13-2011 at 02:59 PM.

  7. #7
    Registered User
    Join Date
    10-13-2011
    Location
    OKC
    MS-Off Ver
    Excel 2007
    Posts
    5

    Re: Macro based on header search

    I got it!! I didn't need the loop in there and finally figured it out. Posting my final code below in case this helps someone else. Thanks for the code that got me going Leith!!

    Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean)
    
    Dim WholeLine As String
    Dim FNum As Integer
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    Dim Cell As Range
    Dim Ext As String
    Dim Rng As Range
    
    
    Application.ScreenUpdating = False
    On Error GoTo EndMacro:
    FNum = FreeFile
    
    
    Set Rng = Range("A1", "GW1")
           For Each Cell In Rng
                If LCase(Cell) Like "*zip4*" Then
                Cell.EntireColumn.Cells.NumberFormat = "0000"
                Else
                If LCase(Cell) Like "*zip*" Then
                Cell.EntireColumn.Cells.NumberFormat = "00000"
           End If
           End If
           Next Cell
    
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If
    
    Open FName For Output Access Write As #FNum
    
    For RowNdx = StartRow To EndRow
        WholeLine = ""
        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = "" Then
                CellValue = ""
            Else
               CellValue = Cells(RowNdx, ColNdx).text
            End If
            CellValue = Replace(CellValue, vbCrLf, "")
            CellValue = Replace(CellValue, vbCr, "")
            CellValue = Replace(CellValue, vbLf, "")
            'CellValue = UCase(CellValue) (This was causing the upper case issue for .jpg)
            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx
        WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        Print #FNum, WholeLine
    
    Next RowNdx
    
    EndMacro:
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #FNum
    
    End Sub
    
    Public Sub DoTheExport()
    
    Dim FName As Variant
    Dim Sep As String
    
    FName = Application.GetSaveAsFilename()
    If FName = False Then
        MsgBox "You didn't select a file"
        Exit Sub
    End If
    Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")
    ExportToTextFile CStr(FName), Sep, MsgBox("Do You Want To Export The Entire Worksheet?", vbYesNo, "Export To Text File") = vbNo
    
    End Sub

  8. #8
    Forum Moderator Leith Ross's Avatar
    Join Date
    01-15-2005
    Location
    San Francisco, Ca
    MS-Off Ver
    2000, 2003, & 2010
    Posts
    23,259

    Re: Macro based on header search

    Hello cardinalsfan0510,

    Well done! It is much more satisfying when you solve a problem yourself and you learn more in the process. Glad I could help.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Tags for this Thread

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1