Consulting

Page 1 of 4 1 2 3 ... LastLast
Results 1 to 20 of 69

Thread: How to set currency with different starting values

  1. #1

    How to set currency with different starting values

    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
    Last edited by Bob Phillips; 04-30-2020 at 01:30 AM. Reason: Added code tags

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    Can you post a workbook so that we can see the data?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    Sorry, attached is the workbook


    PRCBOOK.CSV

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    Quote Originally Posted by GillsITWorld View Post
    Sorry, attached is the workbook
    That looks like a CSV file
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    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
    Semper in excretia sumus; solum profundum variat.

  6. #6
    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.

  7. #7
    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)

  8. #8
    Quote Originally Posted by Paul_Hossler View Post
    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.

  9. #9
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    Is the active sheet empty?
    Semper in excretia sumus; solum profundum variat.

  10. #10

  11. #11
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    I actually meant was the correct sheet active?!? It would give that error if there is no data in the array ar
    Semper in excretia sumus; solum profundum variat.

  12. #12
    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.

  13. #13
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    Then I've hit a wall! Post your workbook you pull the file into.
    Semper in excretia sumus; solum profundum variat.

  14. #14
    Here is the Macro Workbook

    PriceBookMacro.xlsm

  15. #15
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    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
    Semper in excretia sumus; solum profundum variat.

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

  17. #17
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    That was a test! What did the message say?
    Semper in excretia sumus; solum profundum variat.

  18. #18
    Sheet 1 has 1 Rows

  19. #19
    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.

  20. #20
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    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.
    Attached Files Attached Files
    Semper in excretia sumus; solum profundum variat.

Posting Permissions

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