将两个单独的数组压缩成一个

问题描述 投票：0回答：2

这两个脚本按预期工作，它基本上采用一列字符串，过滤某些短语，然后使用 .offset 重命名单元格的内容。在这种情况下，脚本会查看 Phones 和 Tablets 的列表，并查找诸如 4G、5G 和 Cell 之类的东西来确定差异。

唯一的问题是我需要对同一行执行检查的两列，如果 G 列匹配 true 而 P 列匹配 false，则会出现冲突，并且会破坏返回数据的准确性。最后运行的脚本会覆盖 .offset 并最后说。

数据存储到这个变量：
arr结果

我的意图是将相同的脚本合并到一个下，将G和P一起检查，然后在相同的arrResult下将它们过滤掉。

Sub FilterOut()

'Under column G, look for all ipads and samsungs that don't have 4g, 5g, and cell and name them Tablets
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Full Asset List")

Dim lastRow As Long
lastRow = ws.Range("G" & ws.Rows.Count).End(xlUp).Row

Dim arr(): Dim arrResult()
Dim rg As Range: Dim i As Long

Set rg = ws.Range("G1:G" & lastRow)
arr = Application.Transpose(rg)

For i = LBound(arr) To UBound(arr)
    If InStr(arr(i), "SAMSUNG TABLET") <> 0 Or InStr(arr(i), "IPAD") <> 0 Or InStr(arr(i), "ipad") <> 0 Then
        If InStr(arr(i), "64GB") <> 0 Then arr(i) = Replace(arr(i), "64GB", "!@!")
            If InStr(arr(i), "*CELL*") = 0 And InStr(arr(i), "*cell*") = 0 And InStr(arr(i), "4G") = 0 And InStr(arr(i), "5G") = 0 Then
                If InStr(arr(i), "!@!") <> 0 Then arr(i) = Replace(arr(i), "!@!", "64GB")
                j = j + 1
                ReDim Preserve arrResult(1 To j)
                arrResult(j) = arr(i)
            End If
    End If
Next i

With rg
    .AutoFilter field:=1, criteria1:=arrResult, Operator:=xlFilterValues
    .Resize(.Rows.Count - 1, 1).Offset(1, -2).Value = "Tablet"
    .Resize(.Rows.Count - 1, 1).Offset(1, -3).Value = "Tablet"
End With

    ws.AutoFilterMode = False

End Sub

Sub FilterOut2()

'Under column P, look for all ipads and samsungs that don't have 4g, 5g, and cell and name them Tablets
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Full Asset List")

Dim lastRow As Long
lastRow = ws.Range("P" & ws.Rows.Count).End(xlUp).Row

Dim arr(): Dim arrResult()
Dim rg As Range: Dim i As Long

Set rg = ws.Range("P1:P" & lastRow)
arr = Application.Transpose(rg)

For i = LBound(arr) To UBound(arr)
    If InStr(arr(i), "IPAD") <> 0 Or InStr(arr(i), "ipad") <> 0 Then
        If InStr(arr(i), "64GB") <> 0 Then arr(i) = Replace(arr(i), "64GB", "!@!")
            If InStr(arr(i), "CELL") = 0 And InStr(arr(i), "cell") = 0 And InStr(arr(i), "4G") = 0 And InStr(arr(i), "5G") = 0 Then
                If InStr(arr(i), "!@!") <> 0 Then arr(i) = Replace(arr(i), "!@!", "64GB")
                j = j + 1
                ReDim Preserve arrResult(1 To j)
                arrResult(j) = arr(i)
            End If
    End If
Next i

With rg
    .AutoFilter field:=1, criteria1:=arrResult, Operator:=xlFilterValues
    .Resize(.Rows.Count - 1, 1).Offset(1, -11).Value = "Tablet"
    .Resize(.Rows.Count - 1, 1).Offset(1, -12).Value = "Tablet"
End With

    ws.AutoFilterMode = False

End Sub

我曾尝试选择两个范围，但自动过滤器不喜欢那样，我尝试在每一列的循环下运行整个脚本，但再次出现最后说的问题。

编辑 这是我改变的尝试：

Error: Object Variable or with block variable not set

.AutoFilter field:=1, criteria1:=arrResult, Operator:=xlFilterValues

Sub FilterOut3()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Full Asset List")

Dim lastRow As Long
lastRow = ws.Range("P" & ws.Rows.Count).End(xlUp).Row

Dim arr(): Dim arrResult()
Dim rg As Range: Dim i As Long

arr = ws.Range("G1:P" & lastRow).Value

'arr = Application.Transpose(rg)

For i = LBound(arr) To UBound(arr)
    If InStr(arr(i, 1), "IPAD") <> 0 Or InStr(arr(i, 1), "ipad") <> 0 Then
        If InStr(arr(i, 1), "64GB") <> 0 Then arr(i, 1) = Replace(arr(i, 1), "64GB", "!@!")
            If InStr(arr(i, 1), "CELL") = 0 And InStr(arr(i, 1), "cell") = 0 And InStr(arr(i, 1), "4G") = 0 And InStr(arr(i, 1), "5G") = 0 Then
                If InStr(arr(i, 1), "!@!") <> 0 Then arr(i, 1) = Replace(arr(i, 1), "!@!", "64GB")
                j = j + 1
                ReDim Preserve arrResult(1 To j)
                arrResult(j) = arr(i, 1)
            End If
    End If
Next i

With rg
    .AutoFilter field:=1, criteria1:=arrResult, Operator:=xlFilterValues
    .Resize(.Rows.Count - 1, 1).Offset(1, -11).Value = "Tablet"
    .Resize(.Rows.Count - 1, 1).Offset(1, -12).Value = "Tablet"
End With

    ws.AutoFilterMode = False

End Sub
arrays excel vba autofilter cross-reference
2个回答
1
投票

下面结合了两个代码，我也简化了

If
结构 并删除了“64GB”替代品，因为它没有取得任何成就。

Sub FilterOut_Combined()

'Look for all ipads and samsungs that don't have 4g, 5g, and cell in column P or G and name them Tablets

Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("Full Asset List")
Dim lastRow As Long, lRow2 As Long
lastRow = ws.Range("P" & ws.Rows.Count).End(xlUp).Row
lRow2 = ws.Range("G" & ws.Rows.count).End(xlUp).Row
If lRow2 > lastRow Then lastRow = lRow2 'use whichever is bigger

Dim arrP(), arrG(), arrResult()
Dim rgP As Range, rgG as Range, i As Long

Set rgP = ws.Range("P1:P" & lastRow): Set rgG = ws.Range("G1:G" & lastRow)
arrP = Application.Transpose(rgP): arrG = Application.Transpose(rgG)

For i = LBound(arrP) To UBound(arrP)
    If LCase(arrP(i)) Like "*ipad*" Or LCase(arrG(i)) Like "*ipad*" And _
        Not (LCase(arrP(i)) Like "*cell*" Or LCase(arrG(i)) Like "*cell*" Or arrP(i) Like "*4G*" Or arrG(i) Like "*4G*" Or arrP(i) Like "*5G*" Or arrG(i) Like "*5G*") _
        Then
            j = j + 1
            ReDim Preserve arrResult(1 to j)
            arrResult(j) = arrP(i) ' just using P for the filtering
    End If
Next i

With rgP
    .AutoFilter field:=1, criteria1:=arrResult, Operator:=xlFilterValues
    .Resize(.Rows.Count - 1, 1).Offset(1, -11).Value = "Tablet"
    .Resize(.Rows.Count - 1, 1).Offset(1, -12).Value = "Tablet"
End With

    ws.AutoFilterMode = False

End Sub
1
投票

请尝试使用下一个能够合并两个（一维）数组（基于 1）的函数，因为您的问题是：

Function mergeArrays(arr1, arr2) As Variant
   Dim i As Long, k As Long
   Dim arr: arr = arr1: k = 1
   ReDim Preserve arr(1 To UBound(arr1) + UBound(arr2))
   
   For i = UBound(arr1) + 1 To UBound(arr)
        arr(i) = arr2(k): k = k + 1
   Next i
   mergeArrays = arr
End Function

可以通过以下方式进行测试：

Sub testMergeArrays()
   Dim arrResult1, arrResult
    arrResult1 = Application.Transpose(Range("F2:F10").Value)
    arrResult = Application.Transpose(Range("I2:I6").Value)
   arrResult = mergeArrays(arrResult1, arrResult)
   
   'only to visualy see the result (Immediate Window - Ctrl + G):
   Debug.Print Join(arrResult, "|")
End Sub

为了在您的环境中使用它，您应该按以下方式进行：

  1. 在所用代码所在的标准模块顶部声明第一个数组：
   Public arrResult1

并使用它代替您的第一个代码的

arrResult
。

  1. 保持第二个代码不变，并在（现有）上方插入下一行
    With rg
    ：
   arrResult = mergeArrays(arrResult1, arrResult)
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.