Thread: 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

Originally Posted by Leith Ross

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

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

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