Consulting

Results 1 to 18 of 18

Thread: Macro to Delete IF

  1. #1
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location

    Macro to Delete IF

    I am looking to write a macro that will delete the lines if it finds particular characters. If it doesn't find these characters it will automatically go to the next step. The problem is these characters will always be in the A column but I don't know what row they will be in. I know how to do it if I knew which cell it would show in but I need to do a relative reference. I would really appreciate help in this area.

    Daniel

  2. #2
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Hi Daniel,
    try this it will delete the entire row if it contains the word test in column A. Option compare text will let it delete rows with the word test spelled with caps or small letters Test or test will be deleted. If you want it to be cap sensitive then just remove or coment the line Option compare text.
    [vba]
    Option Explicit
    Option Compare Text
    Sub DeleteRows()
    Dim test As Boolean, x As Long, lastrow As Long, col As Long
    Range("A8").Select
    col = ActiveCell.Column
    lastrow = Cells(65536, col).End(xlUp).Row
    For x = lastrow To 1 Step -1
    test = Cells(x, col).Text Like "Test"
    If test = True Then Cells(x, col).EntireRow.Delete
    Next
    End Sub[/vba]
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  3. #3
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    Steve sorry to bother you but I am trying to get it to work and I can't. Here is my code:

    [VBA]Range("A:A").Select
    Selection.Find(What:="Profile", After:=ActiveCell, LookIn:=xlValues, LookAt _
    :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlLast, MatchCase:= _
    False, SearchFormat:=False).SelectSelection.Find(What:="Customer").Select
    'Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    [/VBA]

    This is part of a much larger macro. Where and how would I replace my code with yours?

    Thank you,
    Daniel

  4. #4
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Daniel,
    Are you trying to find the word "Profile" in column A and if found delete the entire row or just select it?

    Also are you looking for multiple criteria, eg. also looking for "Customer" and delete those rows?
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  5. #5
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Here's an example using one criteria
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  6. #6
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    Steve thanks that works but can you help me alter it a little. If it finds Profile then it will delete that row and every one after it.

    Daniel

  7. #7
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    I must be misunderstansifying you Daniel....Do you mean everything or just every instance of "Profile"?!?

    see attachment

    It doesn't delete any rows that don't have "profile" in column A for me..See example. Now if you want to leave some instances of Profile thats different.

    By the way, you have been pretty busy here and you haven't given us the whole of what your trying to do, only bits of code in 4 or 5 posts. Is this an assignment or can we see the whole thing. Might make it easier to put it together. Remove any sensitive data.
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  8. #8
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    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:

    [vba]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").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

    [/vba]

    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.

  9. #9
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    You weren't misunderstanding me I explained it wrong. I need to Delete find Profile and then delete Profile and everything after it. Don't worry your code helped me in another spot.

  10. #10
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Well Daniel, I just don't know what to say. I am pretty much a novice at this myself so here are just a couple of things I have noticed. Hope one of the sharper members come along to help you out.

    1st thing I see is that a lot of this could be done with a template...headers, formatting, etc.

    second thing I see that could be improved is that you do a lot of selecting, then copy, paste, etc. take a look at post 2 of this thread....only select is to pick a cell in the column we wish to perform the operation on.

    ps did you get to look at the attachment from post#7
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  11. #11
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Oh, so that is what you want....to find profile and then delete everything after it?........?

    It would really help if you would take the time to think about your questions and word them so an old cow hand can follow ya...we're kinda slow.....
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  12. #12
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    How do you do templates? I have no idea on that one.

  13. #13
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Set up your sheet the way you want it then do a file-saveas .xlt or template
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  14. #14
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    [vba]
    Option Explicit

    Option Compare Text
    Sub DeleteRows()
    Dim test As Boolean, x As Long, lastrow As Long, col As Long
    Range("A8").Select
    col = ActiveCell.Column
    lastrow = Cells(65536, col).End(xlUp).Row
    For x = lastrow To 1 Step -1
    test = Cells(x, col).Text Like "Test"
    If test = True Then Cells(x, col).EntireRow.Delete
    Next
    End Sub
    [/vba]

    I get this to work but I would like to put it into a much larger macro. Right now I have it in a seperate module. How can I do this?

  15. #15
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Hi Daniel,
    You can call the DeleteRows macro from your other routine like this on a line by itself:
    [VBA]
    call DeleteRows
    [/VBA]

    or you can just put this part in your code and see if you have any conflicts: I would put the Dim line(first line) at the very top of the module but you don't have to.
    [VBA]Dim test As Boolean, x As Long, lastrow As Long, col As Long
    Range("A8").Select
    col = ActiveCell.Column
    lastrow = Cells(65536, col).End(xlUp).Row
    For x = lastrow To 1 Step -1
    test = Cells(x, col).Text Like "Test"
    If test = True Then Cells(x, col).EntireRow.Delete
    Next[/VBA]
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

  16. #16
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    Lucas,

    Thank you for all your help but what about the Option Explicit and Option Compare Text where would I put them?

  17. #17
    VBAX Master
    Joined
    Jun 2006
    Posts
    1,091
    Location
    the reason why I am trying to put it into one module is I am installing this Macro around my office and it would be easier to copy one module than 2. I also plan on updating it and if I update that part of the macro I will have to update two modules also.

  18. #18
    Moderator VBAX Wizard lucas's Avatar
    Joined
    Jun 2004
    Location
    Tulsa, Oklahoma
    Posts
    7,323
    Location
    Option explicit and Option compare text must be at the very top of the code module. Outside of any subs
    Steve
    "Nearly all men can stand adversity, but if you want to test a man's character, give him power."
    -Abraham Lincoln

Posting Permissions

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