The time has come! The new website is up and running https://www.excelwtf.com/learn/ Check it out if you want to learn VBA or brush up on your Excel skills with some more advanced Excel tutorials!
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.
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 :
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 :
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
Share this post
Link to post
Share on other sites