Question

我有一个excel宏，可以搜索列中的许多值并将数据放入另一个工作表中。然而，数据是分散的，需要安排它。

这是使用

的宏

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

以下是如何在我的工作表中设置数据

enter image description here

我想从列中添加以下内容十字架：替换：交叉：

另外，我将.Name设置为我的searchString和.FieldNames设置为true但它们没有显示。

我想要的最终结果是

+---------------+--------------+--------------+--------------+
- SearchString  -     Sub      -     Sub      -     Sub      -
+---------------+--------------+--------------+--------------+
-   AR34567     -   A-TY25993  -              -              -
-   AR11160     -    TS-1087   -   AR11300    -   D2-0099N   -
+---------------+--------------+--------------+--------------+

AR11160会有更多的子列，只需在上面的表格中添加一些就可以了解我想要的内容。

更新

我能够根据需要开始调整数据。但是，我似乎只能在同一行获得我需要的数字。在上图中，您会看到列K在Crossed From：下有多个数字。所以我也需要带上所有这些数字。

请帮忙

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

另一个更新 另一个更新

我知道数据的放置方式就像我想要的那样。只有一个问题。当搜索到一个值但未找到时，我在此行中收到错误[.Refresh BackgroundQuery：= False]

如果没有返回结果，我怎么能告诉这段代码跳过它？

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

回答您最新更新的问题

我知道数据的放置方式就像我想要的那样。只有一个问题。当搜索到一个值但未找到时，我在此行中收到错误[.Refresh BackgroundQuery：= False]

如果没有返回结果，我怎么能告诉这段代码跳过它？

以下是带有错误处理程序的完整代码。

我在行On Error Resume Next之前添加了.Refresh BackgroundQuery语句。

之后，它会检查是否发生了错误：

如果不是，它就像现在一样执行你的代码。

如果是，那么它会跳过你的代码，重置错误处理程序，然后转到下一个 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

需要将从Web收到的数据重组为excel

1 个答案: