Djblois
06-12-2006, 12:00 PM
ok sorry, it is a Macro I am writing for my internship. They have a terrible system here that whenever myself or anybody else prints a sales report we need to clean it up. Delete rows of garbage, add customer names, product names, etc. Here is the code:
Sub CleanData()
'
' Macro1 Macro
' Macro recorded 5/19/2006 by Administrator
'
' Keyboard Shortcut: Ctrl+Shift+C
'
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Set WB = ActiveWorkbook
'Name Sheet1
MyInput = InputBox("What do you want to name the Worksheet?")
Sheets("Sheet1").Name = MyInput
'Sort
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
'Delete extra
Columns("A:A").Select
Selection.Find(What:="AT", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
ActiveCell.Offset(-1, 0).Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.EntireRow.Delete
'Create Customer and Product worksheet
Columns("A:A").Select
Selection.Find(What:="Customer:", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Cut
Sheets.Add.Name = "Customers"
Range("A1").Select
ActiveSheet.Paste
Columns("A:A").Select
Selection.Find(What:="Product:", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=last, MatchCase:= _
False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Cut
Sheets.Add.Name = "Products"
Range("A1").Select
ActiveSheet.Paste
'Delete any rows that start with "Profile"
'For i = 2 To 7000
'If Cells(i, 1).Value = "Profile" Then
'Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
'Selection.EntireRow.Delete
'End If
'Next I
DeleteProfile
'Remove ( and ) from data
Columns("A:A").Select
Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Sheets("Customers").Select
Range("A:A").Select
Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Delete any rows that start with "Date"
Columns("A:A").Select
For I = 2 To 3000
If Cells(I, 1).Value = "Date" Then
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.EntireRow.Delete
End If
Next I
'Create Cust# Column
Range("H1").Select
ActiveCell.FormulaR1C1 = "=Mid(RC[-7],11,4)"
Selection.Copy
ActiveCell.Offset(0, -7).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 7).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Create Customer Column
Range("I1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-8],16,50)))"
Selection.Copy
ActiveCell.Offset(0, -8).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 8).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Create headings for Customer worksheet
Columns("A:G").Delete Shift:=xlToLeft
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "Cust#"
Range("B1").FormulaR1C1 = "Customer"
Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Create Item# Column
Sheets("Products").Select
Range("H1").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-7],6)"
Selection.Copy
ActiveCell.Offset(0, -7).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 7).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Create Products Column
Range("I1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-8],10,80)))"
Selection.Copy
ActiveCell.Offset(0, -8).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 8).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Create headings for Product worksheet
Columns("A:G").Delete Shift:=xlToLeft
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "Item#"
Range("B1").FormulaR1C1 = "Product"
Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Save Workbook as User Input
Sheets(3).Select
MyInput = InputBox("What do you want to name the File?")
ActiveWorkbook.SaveAs Filename:= _
"H:\@temp\Daniel B\Current Projects\" & MyInput
'ActiveWorkbook.SaveAs Filename:= _
"H:\@temp\Daniel B\Current Projects\Current"
'Delete Columns
Columns("C:C").Delete Shift:=xlToLeft
Columns("F:F").Delete Shift:=xlToLeft
Columns("P:P").Delete Shift:=xlToLeft
'Insert Columns
Columns("D:D").Insert Shift:=xlToRight
Columns("F:F").Insert Shift:=xlToRight
Columns("H:H").Insert Shift:=xlToRight
Columns("J:K").Insert Shift:=xlToRight
'Add headers with formating
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "Invoice#"
Range("B1").FormulaR1C1 = "Date"
Range("C1").FormulaR1C1 = "Whse#"
Range("E1").FormulaR1C1 = "Cust#"
Range("G1").FormulaR1C1 = "Sls#"
Range("I1").FormulaR1C1 = "Item#"
Range("L1").FormulaR1C1 = "Qty"
Range("M1").FormulaR1C1 = "Units"
Range("N1").FormulaR1C1 = "Price"
Range("O1").FormulaR1C1 = "D"
Range("P1").FormulaR1C1 = "Amt"
Range("Q1").FormulaR1C1 = "Equivalant"
Range("R1").FormulaR1C1 = "Ext-Cost"
Range("S1").FormulaR1C1 = "Unit-Cost"
Range("T1").FormulaR1C1 = "Profit"
Range("U1").FormulaR1C1 = "%"
Range("A1:U1").Select
With Selection
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
'Clean Bottem of Database
'For I = 2 To 65000
'If Cells(i, 1).Value = "Atalanta" Then
'Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
'Selection.EntireRow.Delete
'test = Cells(x, col).Text Like "Test"
'If test = True Then Cells(x, col).EntireRow.Delete
'End If
'Next I
'Open Atalanta Codes workbook
Workbooks.Open Filename:="H:\@temp\Daniel B\Reference\Atalanta Codes.xls"
WB.Activate
'Add Warehouses
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]Whses'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").FormulaR1C1 = "Whse"
'Add Customers from Atalanta Codes
Columns("E:E").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("F2").Select
'ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]Cust'!C1:C9,2,FALSE)"
'Selection.Copy
'ActiveCell.Offset(0, -1).Range("A1").Select
'Selection.End(xlDown).Select
'ActiveCell.Offset(0, 1).Range("A1").Select
'Range(Selection, Selection.End(xlUp)).Select
'ActiveSheet.Paste
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues
'Add Customers from Customer List
'Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Columns("E:E").Select
'If Selection.Find(What:="#N/A\") Then
'Selection.Find(What:="#N/A\").Select
'Selection.Insert Shift:=xlDown
'ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Customers!C[-5]:C[-4],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
'Selection.End(xlDown).Select
'ActiveCell.Offset(0, -1).Range("A1").Select
'Selection.EntireRow.Delete
Range("F1").FormulaR1C1 = "Customer"
'Else
'Add SlsPrsn
Columns("G:G").Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("H2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]SlsPrsn'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("H1").FormulaR1C1 = "SlsPrsn"
'Add Product
Columns("I:I").Select
Selection.TextToColumns Destination:=Range("I1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("J2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Products!C[-9]:C[-8],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("J1").FormulaR1C1 = "Product"
'Add Dept
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-2],'[Atalanta Codes.xls]Products'!C1:C12,3,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("K1").FormulaR1C1 = "Dept"
'Add Delivery, XWhse
Range("N2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Replace What:="", Replacement:="Exw", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="D", Replacement:="Del", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Close Atlanta Codes workbook and delete product and customer lists
Windows("Atalanta Codes.xls").Close
Sheets("Customers").Delete
Sheets("Products").Delete
'Fix Date
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 3), TrailingMinusNumbers:=True
Selection.NumberFormat = "mm/d/yy;@"
'Fix Qty
Columns("L:L").Select
Selection.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Fix Units
Columns("M:M").Select
Selection.TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.Style = "Comma"
'Fix Price
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.Style = "Comma"
'Fix Amt
Columns("P:P").Select
Selection.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Fix Equivalant
Columns("Q:Q").Select
Selection.TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Fix Ext-Cost
Columns("R:R").Select
Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Fix Unit-Cost
Columns("S:S").Select
Selection.TextToColumns Destination:=Range("S1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Fix Profit
Columns("T:T").Select
Selection.TextToColumns Destination:=Range("T1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "#,##0"
'Add Percentage to End
Range("U2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-5]"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Columns("U:U").NumberFormat = "0.00%"
'Set Print Headings
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,Bold""&12Grocery Dept."
.CenterHeader = "&""Arial,Bold""&14&A"
.RightHeader = "&""Arial,Bold""&12Sorted by"
.LeftFooter = "&""Arial,Bold""&D &T Dan Blois"
.CenterFooter = "&""Arial,Bold""&F"
.RightFooter = "&""Arial,Bold""Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.9)
.BottomMargin = Application.InchesToPoints(0.6)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintGridlines = True
.CenterHorizontally = True
.FitToPagesWide = 1
.PrintTitleRows = "$1:$1"
End With
'End If
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I didn't post it because it is so long. I know I need to clean it up also, any help would be greatly appreciated as I want to be a better programmer. Just to let you know I am a business student but I feel Macro writing is an invaluable skill as I move up in my career to get more things done in less time.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.