Posts by Hanes109

Hanes109 · Dec 2nd 2022

I'm working on vba project to hit api (get request) with key and get the response as json and paste it in excel. I'm finding it difficult to split and paste in next line of excel sheet. Can anyone please educate how to achieve this?

Attached 2 images with expected output.

Code

Sub restAPICall()
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim json As Object
Dim i As Integer
Dim rw, cl As Integer
rw = 2: cl = 1

Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = ""
blnAsync = True

With objRequest
    .Open "GET", strUrl, blnAsync
    .SetRequestHeader "apikey", ""
    .send
    
     While objRequest.readyState <> 4
     DoEvents
     Wend
     strResponse = .responsetext
     
     jsontext = VBA.Split(strResponse, ",")
     
     Do Until
     
     For i = LBound(jsontext) To UBound(jsontext)
     
     'Sheet1.Cells(rw, cl).Value = VBA.Replace(VBA.Replace(VBA.Right(jsontext(i), Len(jsontext(i)) - VBA.InStr(1, jsontext(i), ":")), "}", ""), """", "")
     Sheet1.Cells(rw, cl).Value = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Right(jsontext(i), Len(jsontext(i)) - VBA.InStr(2, jsontext(i), ":")), Chr(34), ""), "[", ""), "]", ""), "{", ""), "}", ""), "sv_id:", "")
     cl = cl + 1
     Next i
     cl = 1
     rw = rw + 1
Loop
End With

End Sub

Display More

Hanes109 · Sep 20th 2021

Hi All,

I want to update this formula through vba code..

Formula:

=VLOOKUP(VLOOKUP(.Cells(i,6),[Macrobook_V_0.3.6.xlsm]DB_list!$A:$B,2,0),'[Input.xlsx]FREETIME OVERVIEW'!$B:$F,MATCH(VLOOKUP(H2,[Macrobook_V_0.3.6.xlsm]Containers!$A:$B,2,0),'[Input.xlsx]FREETIME OVERVIEW'!$B$10:$F$10,0),0)

So I wrote this down but its not working. Can anyone please explain what I'm missing in this code.

Code

Dim r As Range, r2 As Range, r3 As Range
Set r = wb3.Sheets(5).[b10].CurrentRegion
Set r2 = ThisWorkbook.Sheets("DB_List").Cells(1).CurrentRegion
Set r3 = ThisWorkbook.Sheets("Containers").Cells(1).CurrentRegion

= Application.VLOOKUP(Application.VLOOKUP(.Cells(i, 6), r2, 2, 0), r2, Application.MATCH(Application.VLOOKUP(.Cells(i, 8), r3, 2, 0), r, 0), 0)

Hanes109 · Sep 18th 2021

Thank you so much, KjBox!! It works perfect..!!!

Hanes109 · Sep 17th 2021

Alright, thanks for sharing and like.

Hanes109 · Sep 17th 2021

Try, Adding this code at beginning

Code

Worksheets("Sheet1").Unprotect "Password"

Add this at end of the code

Code

Worksheets("Sheet1").Protect "Password"

If this doesn't work, please post sample file.

Hanes109 · Sep 17th 2021

Code

.Cells(2, lh) = Application.VLookup(.Cells(2, 7), x, 2, False)

KjBox royUK

I require lookup code to be filled down but its returning same value for all the cells. Can anyone tell me what I'm missing here..

Code

Sub Dumyx()

Dim FName, wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook
Dim Lastrow As Long
Dim Lastrowx As Long
Dim wb2s As Worksheet
Dim rng As Range
Dim x As Range

FName = Application.GetOpenFilename("excel files,*.csv", , "Select DND Format", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 1 Then
Set wb1 = Workbooks.Open(FName(1))
Else
MsgBox "Please select DnD format", 16, "Rate Automation - To Update DND format"
Exit Sub
End If

FName = Application.GetOpenFilename("excel files,*.csv", , "Select L3", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 1 Then
Set wb2 = Workbooks.Open(FName(1))
Else
MsgBox "Please select L3", 16, "Rate Automation - To Update DND format"
Exit Sub
End If

FName = Application.GetOpenFilename("excel files,*.xlsx", , "Select Input", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 1 Then
Set wb3 = Workbooks.Open(FName(1))
Else
MsgBox "Please select Input", 16, "Rate Automation - To Update DND format"
Exit Sub
End If

Set rng = wb1.Sheets(1).Range("A1:P1")
Set delcol = wb1.Sheets(1).Range("A1:P1")
Set delcolx = wb1.Sheets(1).Range("A:P")
Set x = wb3.Sheets(5).Range("B:C")
Set wb2s = wb2.Sheets(1)

Application.ScreenUpdating = False

With wb1.Sheets(1)

Lastrowx = wb2.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row

wb2s.Range("A2:A" & Lastrowx).Copy .Range("E2")
wb2s.Range("B2:B" & Lastrowx).Copy .Range("F2")
wb2s.Range("D2:D" & Lastrowx).Copy .Range("H2")
wb2s.Range("ABV2:ABV" & Lastrowx).Copy .Range("B2")
wb2s.Range("ABU2:ABU" & Lastrowx).Copy .Range("C2")

wb2.Close

Lastrow = wb1.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row

.Range("D2:D" & Lastrow).FillDown
.Range("G2:G" & Lastrow).FillDown
.Range("J2:J" & Lastrow).FillDown
.Range("K2:K" & Lastrow).FillDown

lg = wb1.Sheets(1).Rows("1").Find("destination").Column

.Columns(lg + 1).EntireColumn.Insert Shift:=xlToRight
.Cells(1, lg + 1) = "Country"
.Cells(2, lg + 1).Formula = "=VLOOKUP(F2,XFC:XFD,2,0)"
.Range("G2:G" & Lastrow).FillDown

'lx = wb3.Sheets(5).Range("B:C")
lh = wb1.Sheets(1).Rows("1").Find("free_time").Column

.Cells(2, lh) = Application.VLookup(.Cells(2, 7), x, 2, False)

'.Cells(2, lh).Formula = "=VLOOKUP(G2,,2,0)"
.Range("j2:j" & Lastrow).FillDown

delcolx.CurrentRegion
delcolx.Cells.Copy
delcolx.Cells.PasteSpecial xlPasteValues

Application.CutCopyMode = False

For Each cell In delcol
If cell.Value = "Country" Then cell.EntireColumn.Delete
Next

End With

wb3.Close

End Sub

Display More

Hanes109 · Sep 14th 2021

That works perfect!!! Thank you so much KjBox !

Hanes109 · Sep 14th 2021

Run time error 438. Object doesn't support property or this method.

Hanes109 · Sep 14th 2021

royUK I get error while running your code..in the same line

Lastrow = wb1.Range("B" & Rows.Count).End(xlUp).Row

Hanes109 · Sep 14th 2021

royUK Yes, Exactly.

I am not sure where to place the below code.. Because column"B" also updates with this code.

Lastrow = wb1.Range("B" & Rows.Count).End(xlUp).Row

Hanes109 · Sep 14th 2021

Hi, I'm struck in VBA code to find number of rows after fetching the data from another workbook and autofill.

Macro placed in separate file Dumhost.xlsm( Macro workbook) to update Dummy format.csv (File1) from Xando.csv work (file2).

Code

Sub Dum()
Dim FName, wb1 As Workbook, wb2 As Workbook
Dim x, y, i As Long, ii As Long, iii As Long, s As String
Dim Lastrow As Long
FName = Application.GetOpenFilename("excel files,*.csv", , "Select Dummy format & Xando file", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 2 Then
Set wb1 = Workbooks.Open(FName(1))
'wb1=Dummy format
Set wb2 = Workbooks.Open(FName(2))
'wb2=Xando
Lastrow = wb1.Range("B" & Rows.Count).End(xlUp).Row


Else
MsgBox "Please select DnD format & L3 file", 16, "To Update DND format"
Exit Sub
End If


Application.ScreenUpdating = 0
wb2.Sheets(1).Range("A2:A5000").Copy _
wb1.Sheets(1).Range("E2")
wb2.Sheets(1).Range("B2:B5000").Copy _
wb1.Sheets(1).Range("F2")
wb2.Sheets(1).Range("D2:D5000").Copy _
wb1.Sheets(1).Range("H2")
wb2.Sheets(1).Range("ABV2:ABV5000").Copy _
wb1.Sheets(1).Range("B2")
wb2.Sheets(1).Range("ABU2:ABU5000").Copy _
wb1.Sheets(1).Range("C2")
wb1.Sheets(1).Range("D2").Select
wb1.Sheets(1).Range("D2:D" & Lastrow).FillDown
wb1.Sheets(1).Range("G2").Select
wb1.Sheets(1).Range("G2:G" & Lastrow).FillDown
wb1.Sheets(1).Range("J2").Select
wb1.Sheets(1).Range("J2:J" & Lastrow).FillDown
wb1.Sheets(1).Range("K2").Select
wb1.Sheets(1).Range("K2:K" & Lastrow).FillDown
End Sub

Display More

Hanes109 · Aug 10th 2021

It works perfectly. Thank you so much...!!!

Hanes109 · Aug 9th 2021

Please help KjBox...!

Hanes109 · Aug 9th 2021

Thank you for the reply.

Attached the workbook (please process sheet6).

Below is the code which gets highlighted to debug.

Code

i = Application.Match(y(LBound(y)), xx, 0)

Hanes109 · Aug 9th 2021

Hi KjBox, hope you're doing good..

I'm getting error when running this code and found the root cause as "Header is not string". Its actually value.

Please help.

Thanks!!

Code

Option Explicit
Sub AddData()
 Dim x, xx, y, yy, i As Long, ii As Long, s As String, sSht As String
 Dim sInput As String, wbk As Workbook, ws As Worksheet
 
 Set wbk = Workbooks("S1") 'CHANGE AS REQUIRED
 
 sInput = InputBox("Enter Sheet, Header, Amount, Currency (separated by comma & a space)", "Data Entry")
 
 If sInput <> "" Then
 y = Split(sInput, ", ")
 sSht = y(LBound(y))
 Set ws = wbk.Sheets(sSht)
 With ws.Cells(1).CurrentRegion
 x = .Value
 xx = .Rows(1)
 i = Application.Match(y(LBound(y) + 1), xx, 0)
 For ii = 2 To UBound(x, 1)
 x(ii, i) = Format(CDbl(y(LBound(y) + 2)), "#.00")
 x(ii, i + 1) = y(UBound(y))
 Next
 .Value = x
 End With
 End If
 
End Sub

Display More

Hanes109 · May 29th 2021

Quote

Sorry, I thought you wanted all the sheets updating at the same time (but with different data).

Is this even possible??

Hanes109 · May 29th 2021

You're the best KjBox. Thank you so much!!!!

Hanes109 · May 29th 2021

Quote

I think the best method would be to have an Input area on the Active workbook where you would enter all 6 Headers, Amounts and Currencies, then click a button to run the macro and update the Output Workbook

I thought you asked me to add input sheet. I don't require it. Msgbox works fine.

Your previous macro works but

I don't require this combo. - Header7, Truck7, 134, CAD

Required combination -

Example 1 - Truck7, 134, CAD

Example 2 - Header7, 154, USD

Example 3- Ducatti1, 156,AED

Macro will be running through personal macro workbook.

Hanes109 · May 29th 2021

Attached the workbook..

Hanes109 · May 29th 2021

Sure, Thanks for your suggestion. I will do the same.

Posts by Hanes109

Vba split string and paste in next line

Vlookup vba code

Dynamic Autofill

VBA - How to Lock and Unlock a Password Protected Sheet While trying to add/insert with VBA

VBA - How to Lock and Unlock a Password Protected Sheet While trying to add/insert with VBA

Dynamic Autofill

Dynamic Autofill

Dynamic Autofill

Dynamic Autofill

Dynamic Autofill

Dynamic Autofill

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box

VBA to find column header through Msg Box