Option Explicit
Sub ReorgData()
' hiker95, 08/18/2011
' http://www.mrexcel.com/forum/showthread.php?t=572682
Dim wC As Worksheet, wF As Worksheet, wT As Worksheet
Dim LR As Long, LC As Long, LC2 As Long, a As Long, n As Long, LRT As Long
Dim Area As Range, SR As Long, ER As Long, EC As Long, NR As Long
Application.ScreenUpdating = False
Set wC = Worksheets("Customer Delivery Schedule")
If Not Evaluate("ISREF(Finished!A1)") Then Worksheets.Add(After:=wC).Name = "Finished"
Set wF = Worksheets("Finished")
wF.UsedRange.Clear
wC.UsedRange.Copy wF.Range("A1")
With wF.UsedRange
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
On Error Resume Next
wF.Range("C1", wF.Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
LR = wF.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
LC = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For a = LC To 1 Step -1
n = Application.CountA(wF.Range(wF.Cells(1, a), wF.Cells(LR, a)))
If n = 0 Then wF.Columns(a).Delete
Next a
wF.UsedRange.Columns.AutoFit
wF.Rows(1).Insert
For a = LR To 2 Step -1
If wF.Cells(a, 1) = "Total" Then wF.Rows(a).Offset(1).Insert
Next a
Worksheets.Add().Name = "Temphiker95"
Set wT = Worksheets("Temphiker95")
For Each Area In wF.Range("B1", wF.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
With Area
SR = .Row
ER = SR + .Rows.Count - 1
wT.UsedRange.Clear
EC = wF.Cells(ER, Columns.Count).End(xlToLeft).Column
wF.Range(wF.Cells(SR, 1), wF.Cells(ER, EC)).Copy wT.Range("A1")
LRT = wT.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
For a = EC To 1 Step -1
n = Application.CountA(wT.Range(wT.Cells(1, a), wT.Cells(LRT, a)))
If n = 0 Then wT.Columns(a).Delete
Next a
wF.Range(wF.Cells(SR, 1), wF.Cells(ER, EC)).Clear
wT.UsedRange.Copy wF.Range("A" & SR)
End With
Next Area
LC2 = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For a = LC To LC2 + 1 Step -1
wF.Columns(a).Delete
Next a
wF.Cells(2, LC2 + 2).Resize(, 16) = [{"Contract","Delivery Date","Product Quantity","Product Type","Sales Order No.","Person","Product Quantity","Product Type","Product Quantity","Product Type","Product","Code","Outlet","Ship To","Status","System"}]
For Each Area In wF.Range("B1", wF.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
With Area
SR = .Row
ER = SR + .Rows.Count - 1
NR = wF.Cells(wF.Rows.Count, LC2 + 2).End(xlUp).Offset(1).Row
wF.Range("B" & SR).Copy wF.Cells(NR, LC2 + 2).Resize(ER - 1 - SR - 2)
wF.Range(wF.Cells(SR + 3, 1), wF.Cells(ER - 1, LC2)).Copy wF.Cells(NR, LC2 + 3)
End With
Next Area
For a = LC2 To 1 Step -1
wF.Columns(a).Delete
Next a
Application.DisplayAlerts = False
wT.Delete
Application.DisplayAlerts = True
LR = wF.Cells(Rows.Count, 2).End(xlUp).Row
LC = wF.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
With wF.Range("B3:B" & LR)
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 9
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 24
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 24
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 24
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 24
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 24
End With
End With
wF.Range(wF.Cells(3, 2), wF.Cells(LR, LC)).HorizontalAlignment = xlCenter
With wF.Range("B2:Q2")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 9
.Font.ColorIndex = 2
.Interior.ColorIndex = 47
End With
wF.UsedRange.Columns.AutoFit
wF.Activate
Application.ScreenUpdating = True
End Sub
)
