Jump to content
News Ticker
  • Welcome to the Community
  • Use the forum to troubleshoot your Excel & VBA Problems
  • We will be launching a new website soon! www.ExcelWTF.com/Learn ! Join us to learn VBA from the ground up!

Joeslost

Members
  • Content count

    2
  • Joined

  • Last visited

Community Reputation

0 Neutral

About Joeslost

  • Rank
    Newbie

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

  1. Hello all! My name is Joe and I am going crazy with this issue! Background info: I have a spreadsheet that pulls information from a variable workbook and places it appropriately in a template workbook. Then sorts it deletes and unused data. It really is quite handy. More on the Making of the initial Macro here: http://www.mrexcel.com/forum/excel-questions/944821-macros-switching-between-two-excel-sheets-out-setnames.html The Macro code : Sub Import_Customer_Information() Dim Chr(1 To 80) As Integer Dim X As Integer 'This Makes the macro change without updating the screen with each operation. Application.ScreenUpdating = False 'This sets both open workbooks as variables Dim wb1 As Workbook, wb2 As Workbook Dim answer As Integer 'Ensures There are only 2 workbooks open If Workbooks.Count > 2 Then MsgBox "You may only have 2 Workbooks Open when running this Macro. Exiting...", vbCritical, "Warning" Exit Sub End If If Workbooks.Count < 2 Then MsgBox "You need to have both your customer info sheet and templete file open! Exiting...", vbCritical, "Warning" Exit Sub End If ' Ensures the contract file is set as wb2 and the other is wb1. If ThisWorkbook Is Workbooks(1) Then Set wb1 = Workbooks(2) Set wb2 = ThisWorkbook Else Set wb1 = Workbooks(1) Set wb2 = ThisWorkbook End If 'Checks if Acount is Cod or charge and adds it to the contract respectivly. wb1.Activate Range("AB2").Select Selection.Copy wb2.Activate Range("Q1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Begins to copy information from one workbook to another 'Moving A/r Number wb1.Activate Range("A2").Select Selection.Copy wb2.Activate Range("G8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Company Name wb1.Activate Range("K2").Select Selection.Copy wb2.Activate Range("D9,J3,B13").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Route wb1.Activate Range("AC2").Select Selection.Copy wb2.Activate Range("J6").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Contact wb1.Activate Range("Q2").Select Selection.Copy wb2.Activate Range("G10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Phone wb1.Activate Range("R2").Select Selection.Copy wb2.Activate Range("G11").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Fax wb1.Activate Range("T2").Select Selection.Copy wb2.Activate Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Email wb1.Activate Range("S2").Select Selection.Copy wb2.Activate Range("J11").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Service Address wb1.Activate Range("L2").Select Selection.Copy wb2.Activate Range("B14").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("M2").Select Selection.Copy wb2.Activate Range("B15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("N2").Select Selection.Copy wb2.Activate Range("B16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("O2").Select Selection.Copy wb2.Activate Range("D16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("P2").Select Selection.Copy wb2.Activate Range("G16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Billing Address wb1.Activate Range("U2").Select Selection.Copy wb2.Activate Range("J13").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("V2").Select Selection.Copy wb2.Activate Range("J14").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("W2").Select Selection.Copy wb2.Activate Range("J15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("X2").Select Selection.Copy wb2.Activate Range("J16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("Y2").Select Selection.Copy wb2.Activate Range("J17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("Z2").Select Selection.Copy wb2.Activate Range("K17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("AA2").Select Selection.Copy wb2.Activate Range("M17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ' Moveing man Item no wb1.Activate Range("B2:B82").Select Selection.Copy wb2.Activate Range("B22:B102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Desc line 1 wb1.Activate Range("F2:F82").Select Selection.Copy wb2.Activate Range("D22:D102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Desc line 2 wb1.Activate Range("G2:G82").Select Selection.Copy wb2.Activate Range("G22:G102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Item Inventory wb1.Activate Range("D2:D82").Select Selection.Copy wb2.Activate Range("H22:H102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Weekly Usage wb1.Activate Range("E2:E82").Select Selection.Copy wb2.Activate Range("J22:J102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Weekly Unit Rate wb1.Activate Range("I2:I82").Select Selection.Copy wb2.Activate Range("K22:K102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Min Flat Rate wb1.Activate Range("H2:H82").Select Selection.Copy wb2.Activate Range("M22:M102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Delevery/Fuel Description wb1.Activate Range("AH2").Select Selection.Copy wb2.Activate Range("D104").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Delevery Amount wb1.Activate Range("AG2").Select Selection.Copy wb2.Activate Range("M104").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Class wb1.Activate Range("AI2:AI82").Select Selection.Copy wb2.Activate Range("R22:R102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Group wb1.Activate Range("AD2:AD82").Select Selection.Copy wb2.Activate Range("Q22:Q102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Up Charge Id wb1.Activate Range("AK2").Select Selection.Copy wb2.Activate Range("R103").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Maintain Inventory Percentage wb1.Activate Range("AM2").Select Selection.Copy wb2.Activate Range("G103").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Adds a zero to each cell In the Group column so items with no group will be on top' For Each cell In Range("Q22:Q103") If IsEmpty(cell) Then cell.Value = 0 End If Next 'Check to see if maintain Inventory line is needed and then calcualte charge generated. Select Case Range("R103") Case "02": Range("S21") = "Case 02" Per = 0.08 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "03": Range("S21") = "Case 03" Per = 0.12 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "04": Range("S21") = "Case 04" Per = 0.05 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "05": Range("S21") = "Case 05" Per = 0.2 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "06": Range("S21") = "Case 06" Per = 0.24 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "08": Range("S21") = "Case 08" Per = 0.32 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "09": Range("S21") = "Case 09" Per = 0.12 For Each cell In Range("R22:R102") If cell = "09" Or "14" Then cell.Select Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "4A": Range("S21") = "Case 4A" Per = 0.16 For Each cell In Range("R22:R102") cell.Select If cell.Value = "7" Or "9" Or "11" Or "12" Or "13" Or "14" Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case Else: Range("S21") = "Case NO" Per = 0 Range("A103").EntireRow.Delete GoTo Failed End Select Range("S19") = Per ' Assign my arry Char = Range("S22:S102") 'multiply each entry by a perecentage determined above For r = LBound(Chr, 1) To UBound(Chr, 1) Chr(r) = Chr(r) * Per Next r 'Place the total of the array in M103 Range("M103").Value = WorksheetFunction.Sum(Chr) GoTo Finished Failedcell: Range("S20") = ("Failedcell") GoTo DONEXT Failed: Range("S20") = ("Failed") GoTo DONEXT Finished: Range("S20") = ("Finished") DONEXT: 'Unhides the imported information. Range("B22:B102").EntireRow.Hidden = False 'Sort the rows based on Group in Column Q, Then off The Man# in Column B. Range("B22:S103").Sort key1:=Range("Q22:Q104"), _ order1:=xlAscending, key2:=Range("B22:B104"), _ order2:=xlAscending 'Supress Zero Values ActiveWindow.DisplayZeros = False 'Deletes any unused line based off of the man# column. Dim rng As Range Set rng = Range("B22:B102").SpecialCells(xlCellTypeBlanks) rng.EntireRow.Delete 'This resets screen updating. Application.ScreenUpdating = True End Sub The new Challenge: I need this macro to also take the total charges for each line and add them all together and multiply them by a percentage and place the total on the another line. the curve balls to this situation are that some times I dont need to do this at all, the percentage is different in many cases (determined by an identifier code), not all the lines will need to be totaled and calculated, and the lines needed to be totaled and calculated will change depending on the identifier code. More on why and exactly what here : http://www.mrexcel.com/forum/excel-questions/950379-challenge.html#post4566596 The Code I came up with to solve this situation is this : Select Case Range("R103") Case "02": Range("S21") = "Case 02" Per = 0.08 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "03": Range("S21") = "Case 03" Per = 0.12 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "04": Range("S21") = "Case 04" Per = 0.05 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "05": Range("S21") = "Case 05" Per = 0.2 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "06": Range("S21") = "Case 06" Per = 0.24 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "08": Range("S21") = "Case 08" Per = 0.32 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "09": Range("S21") = "Case 09" Per = 0.12 For Each cell In Range("R22:R102") If cell = "09" Or "14" Then cell.Select Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "4A": Range("S21") = "Case 4A" Per = 0.16 For Each cell In Range("R22:R102") cell.Select If cell.Value = "7" Or "9" Or "11" Or "12" Or "13" Or "14" Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case Else: Range("S21") = "Case NO" Per = 0 Range("A103").EntireRow.Delete GoTo Failed End Select Range("S19") = Per ' Assign my arry Char = Range("S22:S102") 'multiply each entry by a perecentage determined above For r = LBound(Chr, 1) To UBound(Chr, 1) Chr(r) = Chr(r) * Per Next r 'Place the total of the array in M103 Range("M103").Value = WorksheetFunction.Sum(Chr) GoTo Finished Failedcell: Range("S20") = ("Failedcell") GoTo DONEXT Failed: Range("S20") = ("Failed") GoTo DONEXT Finished: Range("S20") = ("Finished") DONEXT: The Problem: It transfers every value in range in column M to S regardless of whether it equates to true for the If statement. I get no results in M103, so I'm not sure If Chr is established, or if it is multiplied by Per, or if it is even summed. I am completely at a loss why this would not work and any help would be amazing. Thanks in advance, Joe
  2. Hello all! My name is Joe and I am going crazy with this issue! Background info: I have a spreadsheet that pulls information from a variable workbook and places it appropriately in a template workbook. Then sorts it deletes and unused data. It really is quite handy. More on the Making of the initial Macro here: http://www.mrexcel.com/forum/excel-questions/944821-macros-switching-between-two-excel-sheets-out-setnames.html The Macro code : Sub Import_Customer_Information() Dim Chr(1 To 80) As Integer Dim X As Integer 'This Makes the macro change without updating the screen with each operation. Application.ScreenUpdating = False 'This sets both open workbooks as variables Dim wb1 As Workbook, wb2 As Workbook Dim answer As Integer 'Ensures There are only 2 workbooks open If Workbooks.Count > 2 Then MsgBox "You may only have 2 Workbooks Open when running this Macro. Exiting...", vbCritical, "Warning" Exit Sub End If If Workbooks.Count < 2 Then MsgBox "You need to have both your customer info sheet and templete file open! Exiting...", vbCritical, "Warning" Exit Sub End If ' Ensures the contract file is set as wb2 and the other is wb1. If ThisWorkbook Is Workbooks(1) Then Set wb1 = Workbooks(2) Set wb2 = ThisWorkbook Else Set wb1 = Workbooks(1) Set wb2 = ThisWorkbook End If 'Checks if Acount is Cod or charge and adds it to the contract respectivly. wb1.Activate Range("AB2").Select Selection.Copy wb2.Activate Range("Q1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Begins to copy information from one workbook to another 'Moving A/r Number wb1.Activate Range("A2").Select Selection.Copy wb2.Activate Range("G8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Company Name wb1.Activate Range("K2").Select Selection.Copy wb2.Activate Range("D9,J3,B13").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Route wb1.Activate Range("AC2").Select Selection.Copy wb2.Activate Range("J6").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Contact wb1.Activate Range("Q2").Select Selection.Copy wb2.Activate Range("G10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Phone wb1.Activate Range("R2").Select Selection.Copy wb2.Activate Range("G11").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Fax wb1.Activate Range("T2").Select Selection.Copy wb2.Activate Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Email wb1.Activate Range("S2").Select Selection.Copy wb2.Activate Range("J11").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Service Address wb1.Activate Range("L2").Select Selection.Copy wb2.Activate Range("B14").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("M2").Select Selection.Copy wb2.Activate Range("B15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("N2").Select Selection.Copy wb2.Activate Range("B16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("O2").Select Selection.Copy wb2.Activate Range("D16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("P2").Select Selection.Copy wb2.Activate Range("G16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Billing Address wb1.Activate Range("U2").Select Selection.Copy wb2.Activate Range("J13").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("V2").Select Selection.Copy wb2.Activate Range("J14").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("W2").Select Selection.Copy wb2.Activate Range("J15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("X2").Select Selection.Copy wb2.Activate Range("J16").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("Y2").Select Selection.Copy wb2.Activate Range("J17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("Z2").Select Selection.Copy wb2.Activate Range("K17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False wb1.Activate Range("AA2").Select Selection.Copy wb2.Activate Range("M17").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ' Moveing man Item no wb1.Activate Range("B2:B82").Select Selection.Copy wb2.Activate Range("B22:B102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moving Desc line 1 wb1.Activate Range("F2:F82").Select Selection.Copy wb2.Activate Range("D22:D102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Desc line 2 wb1.Activate Range("G2:G82").Select Selection.Copy wb2.Activate Range("G22:G102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Item Inventory wb1.Activate Range("D2:D82").Select Selection.Copy wb2.Activate Range("H22:H102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Weekly Usage wb1.Activate Range("E2:E82").Select Selection.Copy wb2.Activate Range("J22:J102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Weekly Unit Rate wb1.Activate Range("I2:I82").Select Selection.Copy wb2.Activate Range("K22:K102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Min Flat Rate wb1.Activate Range("H2:H82").Select Selection.Copy wb2.Activate Range("M22:M102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Delevery/Fuel Description wb1.Activate Range("AH2").Select Selection.Copy wb2.Activate Range("D104").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Delevery Amount wb1.Activate Range("AG2").Select Selection.Copy wb2.Activate Range("M104").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Class wb1.Activate Range("AI2:AI82").Select Selection.Copy wb2.Activate Range("R22:R102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Group wb1.Activate Range("AD2:AD82").Select Selection.Copy wb2.Activate Range("Q22:Q102").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Up Charge Id wb1.Activate Range("AK2").Select Selection.Copy wb2.Activate Range("R103").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Moves Maintain Inventory Percentage wb1.Activate Range("AM2").Select Selection.Copy wb2.Activate Range("G103").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Adds a zero to each cell In the Group column so items with no group will be on top' For Each cell In Range("Q22:Q103") If IsEmpty(cell) Then cell.Value = 0 End If Next 'Check to see if maintain Inventory line is needed and then calcualte charge generated. Select Case Range("R103") Case "02": Range("S21") = "Case 02" Per = 0.08 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "03": Range("S21") = "Case 03" Per = 0.12 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "04": Range("S21") = "Case 04" Per = 0.05 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "05": Range("S21") = "Case 05" Per = 0.2 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "06": Range("S21") = "Case 06" Per = 0.24 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "08": Range("S21") = "Case 08" Per = 0.32 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "09": Range("S21") = "Case 09" Per = 0.12 For Each cell In Range("R22:R102") If cell = "09" Or "14" Then cell.Select Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "4A": Range("S21") = "Case 4A" Per = 0.16 For Each cell In Range("R22:R102") cell.Select If cell.Value = "7" Or "9" Or "11" Or "12" Or "13" Or "14" Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case Else: Range("S21") = "Case NO" Per = 0 Range("A103").EntireRow.Delete GoTo Failed End Select Range("S19") = Per ' Assign my arry Char = Range("S22:S102") 'multiply each entry by a perecentage determined above For r = LBound(Chr, 1) To UBound(Chr, 1) Chr(r) = Chr(r) * Per Next r 'Place the total of the array in M103 Range("M103").Value = WorksheetFunction.Sum(Chr) GoTo Finished Failedcell: Range("S20") = ("Failedcell") GoTo DONEXT Failed: Range("S20") = ("Failed") GoTo DONEXT Finished: Range("S20") = ("Finished") DONEXT: 'Unhides the imported information. Range("B22:B102").EntireRow.Hidden = False 'Sort the rows based on Group in Column Q, Then off The Man# in Column B. Range("B22:S103").Sort key1:=Range("Q22:Q104"), _ order1:=xlAscending, key2:=Range("B22:B104"), _ order2:=xlAscending 'Supress Zero Values ActiveWindow.DisplayZeros = False 'Deletes any unused line based off of the man# column. Dim rng As Range Set rng = Range("B22:B102").SpecialCells(xlCellTypeBlanks) rng.EntireRow.Delete 'This resets screen updating. Application.ScreenUpdating = True End Sub The new Challenge: I need this macro to also take the total charges for each line and add them all together and multiply them by a percentage and place the total on the another line. the curve balls to this situation are that some times I dont need to do this at all, the percentage is different in many cases (determined by an identifier code), not all the lines will need to be totaled and calculated, and the lines needed to be totaled and calculated will change depending on the identifier code. More on why and exactly what here : http://www.mrexcel.com/forum/excel-questions/950379-challenge.html#post4566596 The Code I came up with to solve this situation is this : Select Case Range("R103") Case "02": Range("S21") = "Case 02" Per = 0.08 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "03": Range("S21") = "Case 03" Per = 0.12 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "04": Range("S21") = "Case 04" Per = 0.05 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "05": Range("S21") = "Case 05" Per = 0.2 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "06": Range("S21") = "Case 06" Per = 0.24 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "08": Range("S21") = "Case 08" Per = 0.32 For Each cell In Range("R22:R102") If cell.Value = “07” Or “09” Or “11” Or “12” Or “13” Or “14” Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "09": Range("S21") = "Case 09" Per = 0.12 For Each cell In Range("R22:R102") If cell = "09" Or "14" Then cell.Select Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case "4A": Range("S21") = "Case 4A" Per = 0.16 For Each cell In Range("R22:R102") cell.Select If cell.Value = "7" Or "9" Or "11" Or "12" Or "13" Or "14" Then Range("S" & ActiveCell.Row).Value = Range("M" & ActiveCell.Row).Value End If Next Case Else: Range("S21") = "Case NO" Per = 0 Range("A103").EntireRow.Delete GoTo Failed End Select Range("S19") = Per ' Assign my arry Char = Range("S22:S102") 'multiply each entry by a perecentage determined above For r = LBound(Chr, 1) To UBound(Chr, 1) Chr(r) = Chr(r) * Per Next r 'Place the total of the array in M103 Range("M103").Value = WorksheetFunction.Sum(Chr) GoTo Finished Failedcell: Range("S20") = ("Failedcell") GoTo DONEXT Failed: Range("S20") = ("Failed") GoTo DONEXT Finished: Range("S20") = ("Finished") DONEXT: The Problem: It transfers every value in range in column M to S regardless of whether it equates to true for the If statement. I get no results in M103, so I'm not sure If Chr is established, or if it is multiplied by Per, or if it is even summed. I am completely at a loss why this would not work and any help would be amazing. Thanks in advance, Joe
×