GillsITWorld
04-29-2020, 06:02 PM
Looking for help with a bit of code thrown together I've been using until I realized a problem I'm having.
So this code does a lot of things, however the one I'm having a problem with right now is that the values in column G are based on different decimal places as represented by the number in column H. So some of the values are using 2 decimal places and some are using 3 decimal places. I need a way to convert both values into the correct dollar value.
I was using
'Currency
Dim lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr, "G") = 100
.Cells(lr, "G").Copy
With .Cells(1, "G").Resize(lr, 1)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
End With
.Cells(lr + 1, 1).ClearContents
End With
To convert it currently, but this was before I realized our system was using 2 different values for decimals.
Now I have been using filters to move the data I need however I cannot seem to find a way to filter and fix just the correct data.
Any help would be appreciated.
-----------------------------------------------------------------------------------------------------------------------------------------------------
Sub PRCBOOK_Open()
Dim ws As Worksheet
'Set reference to the sheet in the workbook.
Set ws = Application.ActiveSheet
'Apply Filter
ws.Range("A1:I8000").AutoFilter Field:=9, Criteria1:="N"
'Delete Rows
Application.DisplayAlerts = False
ws.Range("A2:H8000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Delete Coloumn I
Columns(9).EntireColumn.Delete
'Currency
Dim lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr, "G") = 100
.Cells(lr, "G").Copy
With .Cells(1, "G").Resize(lr, 1)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
End With
.Cells(lr + 1, 1).ClearContents
End With
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=8, Criteria1:="3"
'Currency
Dim lr2 As Long
With ActiveSheet
lr2 = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr2, "G") = 1000
.Cells(lr2, "G").Copy
With .Cells(1, "G").Resize(lr2, 1)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
.NumberFormat = "$#,##0.00"
End With
.Cells(lr2 + 1, 1).ClearContents
End With
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Delete Coloumn H
Columns(8).EntireColumn.Delete
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=3, Criteria1:=""
'Delete Rows
Application.DisplayAlerts = False
ws.Range("A2:H8000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Delete Row 1
Rows(1).EntireRow.Delete
'Delete Coloumn B
Columns(2).EntireColumn.Delete
'Inserting a Row at at Row 1
Range("A1").EntireRow.Insert
'Insert Headers
Application.Worksheets("PRCBOOK").Range("A1") = "Item #"
Application.Worksheets("PRCBOOK").Range("B1") = "Description"
Application.Worksheets("PRCBOOK").Range("C1") = "Brand"
Application.Worksheets("PRCBOOK").Range("D1") = "Pack Size"
Application.Worksheets("PRCBOOK").Range("E1") = "UOM"
Application.Worksheets("PRCBOOK").Range("F1") = "Price"
'Delete Coloumn G
Columns(8).EntireColumn.Delete
'Delete Coloumn H
Columns(7).EntireColumn.Delete
'Change Sheet Font Style and Size
With Sheets(1)
.Cells.Font.Name = "Times New Roman"
.Cells.Font.Size = 12
End With
'Center Text
Rows("1").HorizontalAlignment = xlCenter
'Bold Text
Rows("1").Font.Bold = True
Rows("1").Font.Size = 16
Range("A1:F1").Interior.Color = RGB(237, 125, 49)
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=6, Criteria1:=""
'Font Changes
Application.DisplayAlerts = False
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Font.Bold = True
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Font.Size = 14
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Interior.Color = RGB(208, 206, 206)
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Add Borders
With ActiveSheet.UsedRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'AutoFit
Worksheets("PRCBOOK").Range("A:F").Columns.AutoFit
'Save WorkBook
ActiveWorkbook.SaveAs ("C:\Users\Gill\Desktop\PriceBook " & Format(Now(), "DD-MMM-YYYY hh mm AMPM")), FileFormat:=51
'Close WorkBook
ActiveWorkbook.Close
Application.Quit
End Sub
So this code does a lot of things, however the one I'm having a problem with right now is that the values in column G are based on different decimal places as represented by the number in column H. So some of the values are using 2 decimal places and some are using 3 decimal places. I need a way to convert both values into the correct dollar value.
I was using
'Currency
Dim lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr, "G") = 100
.Cells(lr, "G").Copy
With .Cells(1, "G").Resize(lr, 1)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
End With
.Cells(lr + 1, 1).ClearContents
End With
To convert it currently, but this was before I realized our system was using 2 different values for decimals.
Now I have been using filters to move the data I need however I cannot seem to find a way to filter and fix just the correct data.
Any help would be appreciated.
-----------------------------------------------------------------------------------------------------------------------------------------------------
Sub PRCBOOK_Open()
Dim ws As Worksheet
'Set reference to the sheet in the workbook.
Set ws = Application.ActiveSheet
'Apply Filter
ws.Range("A1:I8000").AutoFilter Field:=9, Criteria1:="N"
'Delete Rows
Application.DisplayAlerts = False
ws.Range("A2:H8000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Delete Coloumn I
Columns(9).EntireColumn.Delete
'Currency
Dim lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr, "G") = 100
.Cells(lr, "G").Copy
With .Cells(1, "G").Resize(lr, 1)
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
End With
.Cells(lr + 1, 1).ClearContents
End With
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=8, Criteria1:="3"
'Currency
Dim lr2 As Long
With ActiveSheet
lr2 = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lr2, "G") = 1000
.Cells(lr2, "G").Copy
With .Cells(1, "G").Resize(lr2, 1)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide
.NumberFormat = "$#,##0.00"
End With
.Cells(lr2 + 1, 1).ClearContents
End With
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Delete Coloumn H
Columns(8).EntireColumn.Delete
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=3, Criteria1:=""
'Delete Rows
Application.DisplayAlerts = False
ws.Range("A2:H8000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Delete Row 1
Rows(1).EntireRow.Delete
'Delete Coloumn B
Columns(2).EntireColumn.Delete
'Inserting a Row at at Row 1
Range("A1").EntireRow.Insert
'Insert Headers
Application.Worksheets("PRCBOOK").Range("A1") = "Item #"
Application.Worksheets("PRCBOOK").Range("B1") = "Description"
Application.Worksheets("PRCBOOK").Range("C1") = "Brand"
Application.Worksheets("PRCBOOK").Range("D1") = "Pack Size"
Application.Worksheets("PRCBOOK").Range("E1") = "UOM"
Application.Worksheets("PRCBOOK").Range("F1") = "Price"
'Delete Coloumn G
Columns(8).EntireColumn.Delete
'Delete Coloumn H
Columns(7).EntireColumn.Delete
'Change Sheet Font Style and Size
With Sheets(1)
.Cells.Font.Name = "Times New Roman"
.Cells.Font.Size = 12
End With
'Center Text
Rows("1").HorizontalAlignment = xlCenter
'Bold Text
Rows("1").Font.Bold = True
Rows("1").Font.Size = 16
Range("A1:F1").Interior.Color = RGB(237, 125, 49)
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Apply Filter
ws.Range("A1:H8000").AutoFilter Field:=6, Criteria1:=""
'Font Changes
Application.DisplayAlerts = False
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Font.Bold = True
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Font.Size = 14
ws.Range("A2:F1800").SpecialCells(xlCellTypeVisible).Interior.Color = RGB(208, 206, 206)
Application.DisplayAlerts = True
'Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Clear Filter Tags
Cells.AutoFilter
'Add Borders
With ActiveSheet.UsedRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'AutoFit
Worksheets("PRCBOOK").Range("A:F").Columns.AutoFit
'Save WorkBook
ActiveWorkbook.SaveAs ("C:\Users\Gill\Desktop\PriceBook " & Format(Now(), "DD-MMM-YYYY hh mm AMPM")), FileFormat:=51
'Close WorkBook
ActiveWorkbook.Close
Application.Quit
End Sub