copi and paste

[sna]

hi there

I need your help with vba to transform to convert values from one currency to another currency with division of exchange rate in AD2.
I also need to extract name in column A to column AE like example.how to merge my code into one with simplified vba

Code: Select all

Sub Combinetabs()
Sheets.Add
ActiveSheet.Name = "New Sheet"
Set Dsheet = ActiveSheet
For Each ws In Sheets
    If ws.Name <> "New Sheet" Then
        lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
        lr2 = Dsheet.Cells(Rows.Count, "A").End(xlUp).Row
        If lr2 = 1 Then lr2 = 0
        ws.Rows("1:" & lr).Copy Dsheet.Range("A" & lr2 + 1)
    End If
    
Next ws

End Sub

Sub Transform()

    Set sh = ThisWorkbook.Sheets("New Sheet")
    
    lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
   
    usdRate = sh.Range("AD2").Value

    For i = 2 To lr
        
            With sh
            If .Cells(i, "F").Value = "KHR" Then
                .Range("D" & i).Value = .Range("D" & i).Value / usdRate
                .Range("E" & i).Value = .Range("E" & i).Value / usdRate
                .Range("N" & i).Value = .Range("N" & i).Value / usdRate
                .Range("P" & i).Value = .Range("P" & i).Value / usdRate
                .Range("Q" & i).Value = .Range("Q" & i).Value / usdRate
                .Range("R" & i).Value = .Range("R" & i).Value / usdRate
                .Range("T" & i).Value = .Range("T" & i).Value / usdRate
                .Range("U" & i).Value = .Range("U" & i).Value / usdRate
                .Range("W" & i).Value = .Range("W" & i).Value / usdRate
                .Range("X" & i).Value = .Range("X" & i).Value / usdRate
                .Range("Y" & i).Value = .Range("Y" & i).Value / usdRate
                .Range("Z" & i).Value = .Range("Z" & i).Value / usdRate
            End If
            End With
      Next

End Sub

thx

[snasui]

The example code is below.

Code: Select all

Sub combinetabs()
    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "New Sheet"
    Set Dsheet = ActiveSheet
    For Each ws In Sheets
        If ws.Name <> "New Sheet" Then
            lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
            lr2 = Dsheet.Cells(Rows.Count, "A").End(xlUp).Row
            If lr2 = 1 Then lr2 = 0
            ws.Rows("1:" & lr).Copy Dsheet.Range("A" & lr2 + 1)
        End If
    Next ws
    With Worksheets("New Sheet")
        lr = .Cells(Rows.Count, "B").End(xlUp).Row
        usdRate = .Range("AD2").Value
        If IsEmpty(usdrange) Then
            MsgBox "Please enter USD rate in cell AD2.", vbCritical
            Exit Sub
        End If
        For i = 2 To lr
            If .Cells(i, "F").Value = "KHR" Then
                .Range("D" & i).Value = .Range("D" & i).Value / usdRate
                .Range("E" & i).Value = .Range("E" & i).Value / usdRate
                .Range("N" & i).Value = .Range("N" & i).Value / usdRate
                .Range("P" & i).Value = .Range("P" & i).Value / usdRate
                .Range("Q" & i).Value = .Range("Q" & i).Value / usdRate
                .Range("R" & i).Value = .Range("R" & i).Value / usdRate
                .Range("T" & i).Value = .Range("T" & i).Value / usdRate
                .Range("U" & i).Value = .Range("U" & i).Value / usdRate
                .Range("W" & i).Value = .Range("W" & i).Value / usdRate
                .Range("X" & i).Value = .Range("X" & i).Value / usdRate
                .Range("Y" & i).Value = .Range("Y" & i).Value / usdRate
                .Range("Z" & i).Value = .Range("Z" & i).Value / usdRate
            End If
          Next
    End With
End Sub

[sna]

thanks
One more i need your help with code to add to the previous to get ID name in column AC without writing formula as in attach


thanks

[snasui]

The example code is below.

Code: Select all

Sub combinetab()
    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "New Sheet"
    Set Dsheet = ActiveSheet
    For Each ws In Sheets
        If ws.Name <> "New Sheet" Then
            lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
            lr2 = Dsheet.Cells(Rows.Count, "A").End(xlUp).Row
            If lr2 = 1 Then lr2 = 0
            ws.Rows("1:" & lr).Copy Dsheet.Range("A" & lr2 + 1)
        End If
    Next ws

     usdrate = Sheet1.Range("AD1").Value
        If IsEmpty(usdrate) Then
            MsgBox "Please enter USD rate ", vbCritical
            Exit Sub
        End If
    
    With Worksheets("New Sheet")
        lr = .Cells(Rows.Count, "B").End(xlUp).Row
        idn = ""
        For i = 2 To lr
            If IsNumeric(VBA.Left(.Cells(i, "a"), 4)) And IsEmpty(.Cells(i, "b").Value) Then
                idn = .Cells(i, "a").Value
            End If
            
            If .Cells(i, "F").Value = "KHR" Then
                .Range("D" & i).Value = .Range("D" & i).Value / usdrate
                .Range("E" & i).Value = .Range("E" & i).Value / usdrate
                .Range("N" & i).Value = .Range("N" & i).Value / usdrate
                .Range("P" & i).Value = .Range("P" & i).Value / usdrate
                .Range("Q" & i).Value = .Range("Q" & i).Value / usdrate
                .Range("R" & i).Value = .Range("R" & i).Value / usdrate
                .Range("T" & i).Value = .Range("T" & i).Value / usdrate
                .Range("U" & i).Value = .Range("U" & i).Value / usdrate
                .Range("W" & i).Value = .Range("W" & i).Value / usdrate
                .Range("X" & i).Value = .Range("X" & i).Value / usdrate
                .Range("Y" & i).Value = .Range("Y" & i).Value / usdrate
                .Range("Z" & i).Value = .Range("Z" & i).Value / usdrate
            End If
            If Not IsEmpty(.Range("ab" & i).Value) Then
                .Range("ac" & i).Value = idn
            End If
          Next
    End With
  
End Sub

[sna]

Thanks so much