Macro to reformat data

**snuffnchess** · 07-08-2019, 01:06 PM

Right now,

We are running the following Macro to reformat data but for the most part the macro only does from step 1 to step 2 on the attached sheet. I did not know if there was a way to get it more inclusive so that it can go from Raw Data to Step 2 in one step.

Sub Font()
'
' Font Macro
'
' Keyboard Shortcut: Ctrl+Shift+F
'
    Cells.Select
    Range("B2").Activate
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Application.CutCopyMode = False
End Sub

Sub PONew()

Range("A1").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

Application.Run "PERSONAL.XLSB!PasteVal"

    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "Height"
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "Weight"
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "Case Count"
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "SCAC"
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.FormulaR1C1 = "BOL"

Dim sortArr
Dim cel As Range
sortArr = Array("SO Date", "Ship Date", "Requested", "DC", "Item", "Description", "Purchase Order", "PO Number", "Customer PO Number", "Customer PO #", "Sales Order", _
            "Qty Ordered", "Weight", "Height", "Case Count", "SCAC", "BOL", "Ship To Name", "Address ", "Address", "Address Line 1", "Address Line 2", "City", _
            "State", "Postal Code")

ActiveSheet.Rows(1).Insert xlShiftDown

For Each cel In ActiveSheet.Range("A2:AA2")
    cel.Offset(-1) = Application.Match(cel, sortArr, 0)
Next

With ActiveSheet
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("A1:AA1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A1:AA1000")
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    .Rows(1).Delete

    
    .Columns.AutoFit

End With

    Range("F1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Dim x As String
    With ActiveCell.EntireColumn
        With Range(.Cells(1), .Cells(Rows.Count, 1).End(xlUp))
           x = .Address
           .Value = Evaluate("if(" & x & "<>"""",if(isnumber(" & _
           x & ")," & x & "*1," & x & "),"""")")
        End With
    End With
    
    Range("G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Dim y As String
    With ActiveCell.EntireColumn
        With Range(.Cells(1), .Cells(Rows.Count, 1).End(xlUp))
           y = .Address
          ' .Value = y * 1
           .Value = Evaluate("if(" & y & "<>"""",if(isnumber(" & _
         y & ")," & y & "*1," & y & "),"""")")
        End With
    End With
        Selection.End(xlToLeft).Select
    Selection.End(xlUp).Select
    Application.Run "PERSONAL.XLSB!Font"

Range("A1").Select

'added following line
ActiveSheet.UsedRange.Select
   
  '  Range(Selection, Selection.End(xlToRight)).Select
  '  Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    
'Test PO Space Removal
'   wCol = Application.Match("Customer PO Number", Rows(1), 0)
'   If Not IsError(wCol) Then Columns(wCol).Replace ChrW(160), "", 2
'     wCol = Application.Match("Purchase Order", Rows(1), 0)
'   If Not IsError(wCol) Then Columns(wCol).Replace ChrW(160), "", 2
'     wCol = Application.Match("PO Number", Rows(1), 0)
'   If Not IsError(wCol) Then Columns(wCol).Replace ChrW(160), "", 2
'     wCol = Application.Match("Customer PO #", Rows(1), 0)
'   If Not IsError(wCol) Then Columns(wCol).Replace ChrW(160), "", 2


Dim arrPONos As Variant
Dim strPONos As String
Dim wcol As Variant

    wcol = Application.Match("Customer PO Number", Rows(1), 0)
    
    If Not IsError(wcol) Then
        With Range(Cells(2, wcol), Cells(Rows.Count, wcol).End(xlUp))
            arrPONos = .Value
            strPONos = Join(Application.Transpose(arrPONos), ",")
            strPONos = Replace(strPONos, ChrW(160), "")
            strPONos = Replace(strPONos, Chr(32), "")
            arrPONos = Split(strPONos, ",")
            .NumberFormat = "@"
            .Value = Application.Transpose(arrPONos)
        End With
    End If
        wcol = Application.Match("Purchase Order", Rows(1), 0)
    
    If Not IsError(wcol) Then
        With Range(Cells(2, wcol), Cells(Rows.Count, wcol).End(xlUp))
            arrPONos = .Value
            strPONos = Join(Application.Transpose(arrPONos), ",")
            strPONos = Replace(strPONos, ChrW(160), "")
            strPONos = Replace(strPONos, Chr(32), "")
            arrPONos = Split(strPONos, ",")
            .NumberFormat = "@"
            .Value = Application.Transpose(arrPONos)
        End With
    End If
    wcol = Application.Match("PO Number", Rows(1), 0)
    
    If Not IsError(wcol) Then
        With Range(Cells(2, wcol), Cells(Rows.Count, wcol).End(xlUp))
            arrPONos = .Value
            strPONos = Join(Application.Transpose(arrPONos), ",")
            strPONos = Replace(strPONos, ChrW(160), "")
            strPONos = Replace(strPONos, Chr(32), "")
            arrPONos = Split(strPONos, ",")
            .NumberFormat = "@"
            .Value = Application.Transpose(arrPONos)
        End With
    End If
    wcol = Application.Match("Customer PO #", Rows(1), 0)
    
    If Not IsError(wcol) Then
        With Range(Cells(2, wcol), Cells(Rows.Count, wcol).End(xlUp))
            arrPONos = .Value
            strPONos = Join(Application.Transpose(arrPONos), ",")
            strPONos = Replace(strPONos, ChrW(160), "")
            strPONos = Replace(strPONos, Chr(32), "")
            arrPONos = Split(strPONos, ",")
            .NumberFormat = "@"
            .Value = Application.Transpose(arrPONos)
        End With
    End If





    
    Columns("A:C").Select
    Selection.NumberFormat = "mm/dd/yyyy"
    Range("A1").Select

End Sub

Here is a breakdown of what it needs to do.

1: Replace "SAMS DISTRIBUTION CENTER" with "SDC"
2: If the "PO Number" is the same, then leave the data in the first row that it appears in and delete the data in columns A:D & H:P
3: Delete Column F (description)
4: Delete Blank Rows
5: Change Column Heading "Ship to Name" to DC
6: Then run the "PO New" macro listed above.

Please advise.