Need to restructure data received from web into excel - vba

Question

I have a excel macro that searches many values in a column and puts the data into another worksheet. However the data is scattered and need to arrange it.
Here is the macro im using
Sub Search()
Dim i As Integer, n As Integer, SearchString As String, ws As Worksheet, ws2 As Worksheet
Dim iRet As Integer
Dim strPrompt As String
Dim strTitle As String
strPrompt = "Hit OK when you wish to proceed to the next search item."
strTitle = "Next Search"
Set ws = Sheets("FINAL")
Set ws2 = Sheets("AllData")
n = ws.Range("C2").End(xlDown).Row
For i = 2 To n
SearchString = ws.Cells(i, 3).Value
With Worksheets("Query").QueryTables.Add(Connection:= _
"URL;https://www.*****.com/catalog/***.hsm?ItemNumber=" & SearchString _
, Destination:=Worksheets("Query").Range("A1"))
.Name = SearchString
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
iRet = MsgBox(strPrompt, vbYesNo, strTitle)
If iRet = vbNo Then
End
Else
End If
Next i
End Sub
Here is how the data is being set in my sheet
I would like to have anything that starts with the following put in columns
Crosses To:
Replaces:
Crossed From:
Also, I have my .Name set to my searchString and .FieldNames set to true but they are not showing up.
The end result i would like to have is this
+---------------+--------------+--------------+--------------+
- SearchString - Sub - Sub - Sub -
+---------------+--------------+--------------+--------------+
- AR34567 - A-TY25993 - - -
- AR11160 - TS-1087 - AR11300 - D2-0099N -
+---------------+--------------+--------------+--------------+
There would be more sub column's for AR11160, just put a few in the table above to give you the idea what i want.
UPDATE
I was able to start tweaking the data as I need it. However, I can only seem to get the number i need on the same row. On the image above you see that column K has many numbers under Crossed From:. So I need to bring all those numbers too.
Please help
Sub Search2()
Dim i As Integer, n As Integer, SearchString As String
Dim shFinal As Worksheet, shQuery As Worksheet, shAllData As Worksheet
Dim iRet As Integer
Dim strPrompt As String
Dim strTitle As String
Dim m As Long, p As Long, q As Long, r As Long
Dim vSrc As Variant, vDest() As Variant
Dim r1 As Range
Dim Blank As String
strPrompt = "Hit OK when you wish to proceed to the next search item."
strTitle = "Next Search"
Set shFinal = Sheets("FINAL")
Set shQuery = Sheets("Query")
Set shAllData = Sheets("AllData")
n = shFinal.Range("C2").End(xlDown).Row
q = 1
For i = 2 To n
SearchString = shFinal.Cells(i, 3).Value
Set qt = shQuery.QueryTables.Add(Connection:= _
"URL;https://www.***.com/catalog/***.hsm?ItemNumber=" & SearchString _
, Destination:=Worksheets("Query").Range("A1"))
With qt
.Name = SearchString
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
shAllData.Cells(q, 1) = SearchString
p = 1
Do While p < 30
If shQuery.Cells(p, 4) Like "Replaces:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crossed From:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crosses To:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
p = p + 1
Loop
iRet = MsgBox(strPrompt, vbYesNo, strTitle)
If iRet = vbNo Then
End
Else
shQuery.UsedRange.ClearContents
End If
q = q + 1
Next i
End Sub
ANOTHER UPDATE
Another Update
I know have the data being placed like i want it. Just have one issue. When a value is searched and not found i get a error on this line [.Refresh BackgroundQuery:=False]
How can i tell this code if a result is not returned skip it?
Sub Search2()
Dim i As Integer, n As Integer, SearchString As String
Dim shFinal As Worksheet, shQuery As Worksheet, shAllData As Worksheet
Dim iRet As Integer
Dim strPrompt As String
Dim strTitle As String
Dim m As Long, p As Long, q As Long, r As Long, s As Long
Dim range As range
Dim vSrc As Variant, vDest() As Variant
Dim r1 As range
strPrompt = "Hit OK when you wish to proceed to the next search item."
strTitle = "Next Search"
Set shFinal = Sheets("FINAL")
Set shQuery = Sheets("Query")
Set shAllData = Sheets("AllData")
n = shFinal.range("C2").End(xlDown).Row
q = 1
For i = 2 To n
SearchString = shFinal.Cells(i, 3).Value
Set qt = shQuery.QueryTables.Add(Connection:= _
"URL;https://www.***.com/catalog/***.hsm?ItemNumber=" & SearchString _
, Destination:=Worksheets("Query").range("A1"))
With qt
.Name = SearchString
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
shAllData.Cells(q, 1) = SearchString
p = 1
Do While p < 30
If shQuery.Cells(p, 4) Like "Replaces:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crossed From:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crosses To:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
Set range = shQuery.range("E2:E25")
For Each cell In range
If IsEmpty(cell) Then
Exit For
Else
r = p + 1
shAllData.Cells(q, r) = shQuery.Cells(r, 5)
End If
Next
p = p + 1
Loop
iRet = MsgBox(strPrompt, vbYesNo, strTitle)
If iRet = vbNo Then
shQuery.UsedRange.ClearContents
End
Else
shQuery.UsedRange.ClearContents
End If
q = q + 1
Next i
End Sub

Answer 1

To answer your latest updated question
I know have the data being placed like i want it. Just have one issue. When a value is searched and not found i get a error on this line [.Refresh BackgroundQuery:=False]
How can i tell this code if a result is not returned skip it?
Below is your complete code with an error handler.
I added an On Error Resume Next statement before the line .Refresh BackgroundQuery.
After that, it checks if an error has occurred:
If not it executes your code, like it does now.
If yes, then it skips your code, resets the error handler, and goes to the next i.
Sub Search2()
Dim i As Integer, n As Integer, SearchString As String
Dim shFinal As Worksheet, shQuery As Worksheet, shAllData As Worksheet
Dim iRet As Integer
Dim strPrompt As String
Dim strTitle As String
Dim m As Long, p As Long, q As Long, r As Long, s As Long
Dim range As range
Dim vSrc As Variant, vDest() As Variant
Dim r1 As range
strPrompt = "Hit OK when you wish to proceed to the next search item."
strTitle = "Next Search"
Set shFinal = Sheets("FINAL")
Set shQuery = Sheets("Query")
Set shAllData = Sheets("AllData")
n = shFinal.range("C2").End(xlDown).Row
q = 1
For i = 2 To n
SearchString = shFinal.Cells(i, 3).Value
Set qt = shQuery.QueryTables.Add(Connection:= _
"URL;https://www.***.com/catalog/***.hsm?ItemNumber=" & SearchString _
, Destination:=Worksheets("Query").range("A1"))
With qt
.Name = SearchString
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "1"
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
On Error Resume Next '<-- Added line
.Refresh BackgroundQuery:=False
End With
If Err = 0 Then '<-- Added line
On Error Goto 0 '<-- Added line
shAllData.Cells(q, 1) = SearchString
p = 1
Do While p < 30
If shQuery.Cells(p, 4) Like "Replaces:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crossed From:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
If shQuery.Cells(p, 4) Like "Crosses To:*" Then shAllData.Cells(q, p) = shQuery.Cells(p, 5)
Set range = shQuery.range("E2:E25")
For Each cell In range
If IsEmpty(cell) Then
Exit For
Else
r = p + 1
shAllData.Cells(q, r) = shQuery.Cells(r, 5)
End If
Next
p = p + 1
Loop
iRet = MsgBox(strPrompt, vbYesNo, strTitle)
If iRet = vbNo Then
shQuery.UsedRange.ClearContents
End
Else
shQuery.UsedRange.ClearContents
End If
q = q + 1
End If '<-- Added line
Err = 0 '<-- Added line
Next i
End Sub