How to set currency with different starting values

[GillsITWorld]

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

[Bob Phillips]

Can you post a workbook so that we can see the data?

[GillsITWorld]

Sorry, attached is the workbook


26505

[Paul_Hossler]

Sorry, attached is the workbook

That looks like a CSV file

[paulked]

When you import your CSV, try running this code first to change the prices to dollers.



Sub ToDollers()
Dim ar, i As Long
With ActiveSheet
ar = .Cells(1, 1).CurrentRegion
For i = LBound(ar) To UBound(ar)
On Error Resume Next
If ar(i, 8) = 3 Then
ar(i, 7) = ar(i, 7) / 1000
Else
ar(i, 7) = ar(i, 7) / 100
End If
Next
.Range("A1:I" & UBound(ar)) = ar
.Range("G1:G" & UBound(ar)).NumberFormat = "$#,##0.00"
End With
End Sub

[GillsITWorld]

Awesome, initially this looks good, let me go over the completed document in detail.

What I'm going to guess took you 30 minutes at most to through together, I spent 2 weeks attempting...

Thank you.

[GillsITWorld]

Ok, so now I'm having a new problem, it runs fine on one computer, but when I move it to the server (Where the original code was pulled from) I'm getting a

Run-time error '13': Type Mismatch
on the line

For i = LBound(ar) To UBound(ar)

[GillsITWorld]

That looks like a CSV file

Sorry, yes it actually starts as a .TXT file that gets renamed into a CSV file so that the macro can open it in excel and be able to start.

[paulked]

Is the active sheet empty?

[GillsITWorld]

No

26510

[paulked]

I actually meant was the correct sheet active?!? It would give that error if there is no data in the array ar

[GillsITWorld]

No it was the correct active sheet, because if I put the other filtering and delete in from of the currency conversion it will do those steps.

[paulked]

Then I've hit a wall! Post your workbook you pull the file into.

[GillsITWorld]

Here is the Macro Workbook

26511

[paulked]

Or try this:



Sub ToDollers()
Dim ar, i As Long, lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(3).Row
MsgBox ActiveSheet.Name & " has " & lr & " rows"
ar = .Range("A1:I" & lr)
For i = LBound(ar) To UBound(ar)
On Error Resume Next
If ar(i, 8) = 3 Then
ar(i, 7) = ar(i, 7) / 1000
Else
ar(i, 7) = ar(i, 7) / 100
End If
Next
.Range("A1:I" & UBound(ar)) = ar
.Range("G1:G" & UBound(ar)).NumberFormat = "$#,##0.00"
End With
End Sub

[GillsITWorld]

Ok, now I'm getting the msgbox popup, how can I disable the popup? Also doesn't change anything into Currency

[paulked]

That was a test! What did the message say?

[GillsITWorld]

Sheet 1 has 1 Rows

[GillsITWorld]

Just odd that the first bit of code works perfectly on one machine and does exactly what I need, however it doesn't work on another... Same excel install and everything.

[paulked]

That message proves the wrong sheet is selected.

You are opening the CSV file when you open the workbook to load it... wrong. It won't always have time to change to the newly opened csv file before the code starts to run. It is better to have a button on the excel file that opens the csv, thus allowing excel to open and 'settle' before doing anything. The reason it's working on one and not the other is probably down to disk access times, the server being faster.

To get around this, with no guarantees, I've put a DoEvents in after the file loads. This, in theory, will allow it to run. But a button is far better.

[paulked]

Sorry, forgot to change the csv location back!

[paulked]

Workbooks.Open "C:\temp\prcbook.csv" '("C:\Users\Administrator\Desktop\W\Reports\PRCBOOK.CSV")

to


Workbooks.Open ("C:\Users\Administrator\Desktop\W\Reports\PRCBOOK.CSV")

[paulked]

With button:

[GillsITWorld]

The problem with a button is that this is an automated process on Sunday early morning. No humans are available.

[paulked]

:doh:
Did the DoEvents do it? If not, try uncommenting the line in the Workbook_Open code and change the time in that to 00:00:10, if there is no one about then an extra 10 seconds shouldn't matter :*)

[GillsITWorld]

Ok, just ran the DoEvents and it worked fine while observed. The real test will be this Sunday during normal operation.

So assuming that this current code is good I also have 2 other PriceBooks I'm trying to work with.

So the next question would be how to add an additional 15% onto the currency field, before or after it's been converted.

[paulked]

ar(i, 7) = (ar(i, 7) / 1000) * 1.15
Else
ar(i, 7) = (ar(i, 7) / 100) * 1.15

[GillsITWorld]

Beautiful! Absolutely Beautiful!

As of now, all tests have worked flawlessly.
I have created different macro files for the different price books and this Sunday it will run per my auto scheduler and email out.

Just in case I do start having issues where do I put the


If not, try uncommenting the line in the Workbook_Open code and change the time in that to 00:00:10


Thank you very much for the assistance

[paulked]

In the ThisWorkbook code module:

26517



Private Sub Workbook_Open()
Application.Wait (Now + TimeValue("00:00:10"))
PRCBOOK_Open
End Sub

[paulked]

Happy to help, hope it all goes okay for you :thumb

[GillsITWorld]

So far absolutely fantastic.

Just about done, working on the last part of the pricebook now.

How would I have it open another workbook called "BlankQuote" and copy sheet1 into the first workbook as the first sheet and then close the second workbook?

[paulked]

Sub CopySheet()
Application.ScreenUpdating = False
Workbooks.Open "C:\temp\blankquote.xlsx"
Sheets("Sheet1").Copy Before:=ThisWorkbook.Sheets("Sheet1")
Sheets("Sheet1 (2)").Name = "New Sheet"
Workbooks("blankquote.xlsx").Close 0
End Sub

[GillsITWorld]

Ok, here is everything.

What seems to be happening is that it's taking the .xlsm as the active and pasting stuff to it?

26518
26519
26520

[paulked]

I took it you wanted to put the blank quote sheet into the macro workbook. Do you want it to go into the csv? If so, it will have to be saved as a workbook first and then the sheet added (only one 'sheet' in a csv!)

Is that what is supposed to happen?

[GillsITWorld]

My apologies, yes, basically I'm attempting to output this as single document so that I can email it to Sales people to use daily.

Then we can move the save line to after the formatting then add the copy and paste. (Tried it, but still didn't work)

[paulked]

1 minute!

[GillsITWorld]

Please take your time! You have become my new best friend!

[paulked]

Try this.

I noticed the 15% wasn't in, just in case you've missed it out :wink:

[GillsITWorld]

So far perfect! This one doesn't use the 15% that was for the 2nd workbook. But great looking out!
I'm going to run this and double check all sheets tomorrow but the preliminaries look good!

[paulked]

Excellent! Let me know how it goes, stay safe!

[GillsITWorld]

How would I hide sheet "prcbook"?

[paulked]

Worksheets("prcbook").Visible = False

[GillsITWorld]

haha, I had it close, I just spelled "Visible" incorrectly!

Something I just noticed is that somehow the formula on the completed sheet has added info to the formula in reference to the sheet location but that's not in the original formula

[paulked]

time for sleep now, it's 4:30am here:thumb

[GillsITWorld]

No worries, completely understand! I'll talk with you tomorrow!

[GillsITWorld]

Ok, so working on the last WorkBook the BlankQuote, when it copies the page from the workbook "BlankQuote" it's coping over a Vlookupformula and when it copies and pastes the formula it changes the reference from Sheet2 to #REF in the actual formula.

Would the easier fix be instead of coping the Vlookup code into pricebook, coping the Prcbook into Sheet2 of the BankQuote Form and then have it resave that output?

[GillsITWorld]

Also Updated the BlankQuote it was pulling from.

26531

[GillsITWorld]

I guess what Im looking for is

How to Copy Exact VLookup Formula in VBA without changing the cell reference?

[GillsITWorld]

I believe this is all happening because of the Vlookup on Sheet1 referencing Sheet 2, when trying to move it between workbooks it wants to update the links and it's causing a problem.

[paulked]

Hmmm... Where is the data held for the vlookup?

[GillsITWorld]

Thats coming from the prcbook, it should all be on sheet2 be the end of it

Sheet1 should be the QuoteForm (Labeled Sheet1)
Sheet2 should be the PrcBook (Labeled Sheet2)

[paulked]

Rushed a bit, but try this

[GillsITWorld]

Ok, so now it seems to be having a problem with there being 2 sheets named "Sheet2"

Run-Time Error '1004':
That name is already taken. Try a different one.

[paulked]

Get rid of your sheet2 in the blankquote. I haven't seen that sheet but I guess then you will get your ref! back! I'd run with giving them a blank quote sheet (with no formula) for this Sunday, let's take a look next week. If you send me a working copy of the blankquote (ie with two sheets and vlookup working) I can take a look over the weekend.

[GillsITWorld]

This one with formulas won't go out this Sunday, just the other 2 PriceBooks we worked on.


Below are the attachments

26535
26536
26537

Again, thank you for ALL the support you have given me!

[paulked]

No worries! Have a good, and safe, weekend. We are about to have a 'Zoom' drinks party with a load of friends... if you can't join them, beat them!

[GillsITWorld]

Awesome! You as well, be safe in this crazy world and have a great weekend!

I'm also available all weekend if you have any other questions!

[paulked]

Ok, I think I've sorted it.

Operation:

Schedular opens QuoteSheet.xlsm which then
Opens PrcBook.csv
Re-calculates prices, removes unwanted columns and formats text (do you need to format the text?)
Opens BlankQuote.xlsx
Copies the modified PrcBook to Sheet2 in BlankQuote
Saves BlankQuote with data and time stamp
Closes BlankQuote
Closes PrcBook without saving changes (keeps it intact for any other process)
Quits Excel

I took the liberty of making the following changes to the BlankQuote, please feel free to change to whatever you really want!

Changed the formula so that it is a blank form unless an item is entered or there is an error
Put the average value of the percentages at the bottom of the column
Locked all cells apart from the Item # and Competitors columns and the Contact info. (added a line "Additional Info:" which is also unlocked)

All seems to be fine and dandy, but let me know if you need any further assistance.

Cheers and stay safe :thumb
26547
26548

[GillsITWorld]

Ok, so Im not sure if this is copying the actual prcbook to page 2, any time you try and put an item number in it comes up item not found.

Then when it saves Blankquote with date and time stamp its saving only the prcbook to this workbook.

Then Blankquote just looks like it has the quote form without the prcbook.

[paulked]

I just tried it again and no problems, see attached.

What's on sheet2? It should be the modified csv file like in the attached.

[paulked]

Did you run an earlier version by mistake?

Have you put the new BlankQuote in the directory C:\Users\Administrator\Desktop\W\Reports\?

Are you opening the correct BlankQuote? It will have the timestamp on it similar to my attachment above.

[GillsITWorld]

Ok it was me, I had the BlankQuote.xlsx in the incorrect location. I fixed that.
Then I had to not delete row1 so that item # 1221 would work.
Then I re added the line to hide sheet 2.
I'll have the team go over and make sure it works for them as intended.

This is great! You have been a substantial help!
Other than adding rep to you how else can I repay the time and effort?!

[paulked]

No need for repayment, I'm a VBA intern and learning is payment enough! It is nice to help people, especially in these unprecidented times.

Take care and stay safe :thumb

PS Thanks for the Rep!

[paulked]

BTW, while I was testing I used a count-down routine that enables you to interupt the macro within 10 secs of opening the file. If you don't press a button within the 10 secs the macro runs as normal. You may find it handy for testing yourself, so I've attached it.

[GillsITWorld]

Just wanted to give an update! Everything is working beautifully, all 3 sheets have been successfully implemented into routine!
Again thank you very much, I am now excited to start looking for other VBA projects to optimize time!

[paulked]

Excellent! Stay safe :thumb

[GillsITWorld]

Hello again!
So far everyone is very happy and all of the Pricebooks/Quote Forms are working beautifully!
So again, thank you!
So I have a new VBA Project, should I continue here, or make a new thread?

[paulked]

Hi. Glad it's all okay :thumb

You would have to start a new thread, Stay Safe!

[Paul_Hossler]

And mark this one [SOLVED] using Thread Tools above your first post