求助一个小问题。

LED147258

同样代码。在1个sheet里就好用。

现在我转到4个sheet的工作簿的模块中，就不好用了。我试着做了SET WG=。。然后用WG.range().。也不好用。
求教，怎么改？

Sub 组号()
Dim WD As Worksheet
Set WD = ThisWorkbook.Sheets("排列")
Dim m, n, o, m1, m2, m3, m4, a, b, c, d, a2, b2, c2, d2 As Integer
Dim arr(1 To 4) As String    *这里的arr(1 To 4)对不对？
Dim brr1(), brr2(), brr3()    *这里多个BRR（），怎么一笔带过？
m = 0
n = 0
  o = 0
m1 = 1
m2 = 1
  m3 = 1
   m4 = 1
a = WD.Range("CR2").Value
b = WD.Range("CS2").Value
  c = WD.Range("CT2").Value
   d = WD.Range("CU2").Value
a2 = a + 2
b2 = b + 2
  c2 = c + 2
   d2 = d + 2
arr1 = WD.Range("CR" & 3 & ":CR" & a2)    *这里的ARR1-4，是用ARR1还是ARR（1）
arr2 = WD.Range("CS" & 3 & ":CS" & b2)
  arr3 = WD.Range("CT" & 3 & ":CT" & c2)
   arr4 = WD.Range("CU" & 3 & ":CU" & d2)
For m1 = 1 To a
For m2 = 1 To b
  If Right(arr1(m1, 1), 2) = Left(arr2(m2, 1), 2) Then
  m = m + 1
  ReDim Preserve brr1(1 To m)
  brr1(m) = arr1(m1, 1) & Right(arr2(m2, 1), 2)
For m3 = 1 To c
  If Right(brr1(m), 2) = Left(arr3(m3, 1), 2) Then
  n = n + 1
  ReDim Preserve brr2(1 To n)
  brr2(n) = brr1(m) & Right(arr3(m3, 1), 2)
For m4 = 1 To d
  If Right(brr2(n), 2) = Left(arr4(m4, 1), 2) Then
  o = o + 1
  ReDim Preserve brr3(1 To o)
  brr3(o) = brr2(n) & Right(arr4(m4, 1), 2)
End If
Next m4
End If
Next m3
End If
Next m2
Next m1
WD.Range("CV3").Resize(UBound(brr3), 1) = Application.Transpose(brr3)   *总提示这里有错
Erase arr1
Erase arr2
Erase arr3     *这里这么多ARR，怎么简短的都清除？
Erase arr4
Erase brr1()
Erase brr2()    *这里的BRR，怎么简短的清除内存？
Erase brr3()
Dim arr5, arr6, brr4(), brr5()   **这里，因为上面代码运行完，有个函数计算过程，需要将函数计算结果装入ARR，所以在这里才声明的ARR对吧？
Dim x, y As Long
x = 0
y = 1
arr5 = WD.Range("DP3:DP50001")
arr6 = WD.Range("DQ3:DQ50001")
For y = 1 To 49998
If arr5(y, 1) > 0 Then   *或者提示这里有错
x = x + 1
ReDim Preserve brr4(1 To x)
ReDim Preserve brr5(1 To x)
brr4(x) = arr5(y, 1)
brr5(x) = arr6(y, 1)
End If
Next y
WD.Range("DS3").Resize(UBound(brr4), 1) = Application.Transpose(brr4)   *这两个可能也有错。
WD.Range("DR3").Resize(UBound(brr5), 1) = Application.Transpose(brr5)
Erase arr5
Erase arr6
Erase brr4()
Erase brr5()
MsgBox ("完毕")
End Sub

ykcbf1100

你就几行代码，无法看出是啥问题。

suntao2000

猜下应该是这样吧： WD.Range("CV3").Resize(UBound(ARR, 2)) =

tanglf188

没指定sheetbook吧

LED147258

Sub 组号()
Dim WD As Worksheet
Set WD = ThisWorkbook.Sheets("排列")
Dim m, n, o, m1, m2, m3, m4, a, b, c, d, a2, b2, c2, d2 As Integer
Dim arr(1 To 4) As String
Dim brr1(), brr2(), brr3()
m = 0
n = 0
  o = 0
m1 = 1
m2 = 1
  m3 = 1
   m4 = 1
a = WD.Range("CR2").Value
b = WD.Range("CS2").Value
  c = WD.Range("CT2").Value
   d = WD.Range("CU2").Value
a2 = a + 2
b2 = b + 2
  c2 = c + 2
   d2 = d + 2
arr1 = WD.Range("CR" & 3 & ":CR" & a2)
arr2 = WD.Range("CS" & 3 & ":CS" & b2)
  arr3 = WD.Range("CT" & 3 & ":CT" & c2)
   arr4 = WD.Range("CU" & 3 & ":CU" & d2)
For m1 = 1 To a
For m2 = 1 To b
  If Right(arr1(m1, 1), 2) = Left(arr2(m2, 1), 2) Then
  m = m + 1
  ReDim Preserve brr1(1 To m)
  brr1(m) = arr1(m1, 1) & Right(arr2(m2, 1), 2)
For m3 = 1 To c
  If Right(brr1(m), 2) = Left(arr3(m3, 1), 2) Then
  n = n + 1
  ReDim Preserve brr2(1 To n)
  brr2(n) = brr1(m) & Right(arr3(m3, 1), 2)
For m4 = 1 To d
  If Right(brr2(n), 2) = Left(arr4(m4, 1), 2) Then
  o = o + 1
  ReDim Preserve brr3(1 To o)
  brr3(o) = brr2(n) & Right(arr4(m4, 1), 2)
End If
Next m4
End If
Next m3
End If
Next m2
Next m1
WD.Range("CV3").Resize(UBound(brr3), 1) = Application.Transpose(brr3)


Erase arr1
Erase arr2
Erase arr3
Erase arr4
Erase brr1()
Erase brr2()
Erase brr3()

Dim arr5, arr6, brr4(), brr5()
Dim x, y As Long
x = 0
y = 1
arr5 = WD.Range("DP3:DP50001")
arr6 = WD.Range("DQ3:DQ50001")
For y = 1 To 49998
If arr5(y, 1) > 0 Then
x = x + 1
ReDim Preserve brr4(1 To x)
ReDim Preserve brr5(1 To x)
brr4(x) = arr5(y, 1)
brr5(x) = arr6(y, 1)
End If
Next y

WD.Range("DS3").Resize(UBound(brr4), 1) = Application.Transpose(brr4)
WD.Range("DR3").Resize(UBound(brr5), 1) = Application.Transpose(brr5)
Erase arr5
Erase arr6
Erase brr4()
Erase brr5()
MsgBox ("完毕")

LED147258

Sub 组号()
Dim WD As Worksheet
Set WD = ThisWorkbook.Sheets("排列")
Dim m, n, o, m1, m2, m3, m4, a, b, c, d, a2, b2, c2, d2 As Integer
Dim arr(1 To 4) As String
Dim brr1(), brr2(), brr3()
m = 0
n = 0
  o = 0
m1 = 1
m2 = 1
  m3 = 1
   m4 = 1
a = WD.Range("CR2").Value
b = WD.Range("CS2").Value
  c = WD.Range("CT2").Value
   d = WD.Range("CU2").Value
a2 = a + 2
b2 = b + 2
  c2 = c + 2
   d2 = d + 2
arr1 = WD.Range("CR" & 3 & ":CR" & a2)
arr2 = WD.Range("CS" & 3 & ":CS" & b2)
  arr3 = WD.Range("CT" & 3 & ":CT" & c2)
   arr4 = WD.Range("CU" & 3 & ":CU" & d2)
For m1 = 1 To a
For m2 = 1 To b
  If Right(arr1(m1, 1), 2) = Left(arr2(m2, 1), 2) Then
  m = m + 1
  ReDim Preserve brr1(1 To m)
  brr1(m) = arr1(m1, 1) & Right(arr2(m2, 1), 2)
For m3 = 1 To c
  If Right(brr1(m), 2) = Left(arr3(m3, 1), 2) Then
  n = n + 1
  ReDim Preserve brr2(1 To n)
  brr2(n) = brr1(m) & Right(arr3(m3, 1), 2)
For m4 = 1 To d
  If Right(brr2(n), 2) = Left(arr4(m4, 1), 2) Then
  o = o + 1
  ReDim Preserve brr3(1 To o)
  brr3(o) = brr2(n) & Right(arr4(m4, 1), 2)
End If
Next m4
End If
Next m3
End If
Next m2
Next m1
WD.Range("CV3").Resize(UBound(brr3), 1) = Application.Transpose(brr3)


Erase arr1
Erase arr2
Erase arr3
Erase arr4
Erase brr1()
Erase brr2()
Erase brr3()

Dim arr5, arr6, brr4(), brr5()
Dim x, y As Long
x = 0
y = 1
arr5 = WD.Range("DP3:DP50001")
arr6 = WD.Range("DQ3:DQ50001")
For y = 1 To 49998
If arr5(y, 1) > 0 Then
x = x + 1
ReDim Preserve brr4(1 To x)
ReDim Preserve brr5(1 To x)
brr4(x) = arr5(y, 1)
brr5(x) = arr6(y, 1)
End If
Next y

WD.Range("DS3").Resize(UBound(brr4), 1) = Application.Transpose(brr4)
WD.Range("DR3").Resize(UBound(brr5), 1) = Application.Transpose(brr5)
Erase arr5
Erase arr6
Erase brr4()
Erase brr5()
MsgBox ("完毕")

LED147258

tanglf188 发表于 2022-11-11 16:19
没指定sheetbook吧

代码上传了，有空给看一下哪里有错。并给简化一下。

suntao2000

Sub 组号()
    Dim m&, n&, o&, x&, m1&, m2&, m3&, m4&
    Dim arr, brr1(), brr2(), brr3(), brr4()
    With Sheets("排列")
        arr = .Range("CR3:CU" & .[CR1:CU99999].Find("*", , xlValues, , xlByRows, xlPrevious).Row)
        For m1 = 1 To UBound(arr)
            For m2 = 1 To UBound(arr)
                If Right(arr(m1, 1), 2) = Left(arr(m2, 2), 2) Then
                    m = m + 1
                    ReDim Preserve brr1(1 To m)
                    brr1(m) = arr(m1, 1) & Right(arr(m2, 2), 2)
                    For m3 = 1 To UBound(arr)
                        If Right(brr1(m), 2) = Left(arr(m3, 3), 2) Then
                            n = n + 1
                            ReDim Preserve brr2(1 To n)
                            brr2(n) = brr1(m) & Right(arr(m3, 3), 2)
                            For m4 = 1 To UBound(arr)
                                If Right(brr2(n), 2) = Left(arr(m4, 4), 2) Then
                                    o = o + 1
                                    ReDim Preserve brr3(1 To o)
                                    brr3(o) = brr2(n) & Right(arr(m4, 4), 2)
                                End If
                            Next
                        End If
                    Next
                End If
            Next
        Next
        .Range("Cx3").Resize(UBound(brr3), 1) = Application.Transpose(brr3)
        
        arr = .Range("DP3:DQ" & .[DP1:DQ99999].Find("*", , xlValues, , xlByRows, xlPrevious).Row)
        For m4 = 1 To UBound(arr)
            If arr(m4, 1) > 0 Then
                x = x + 1
                ReDim Preserve brr4(1 To 2, 1 To x)
                brr4(1, x) = arr(m4, 1)
                brr4(2, x) = arr(m4, 2)
            End If
        Next
        .Range("Du3").Resize(UBound(brr4, 2), 2) = Application.Transpose(brr4)
    End With
    MsgBox ("完毕")
End Sub

LED147258

suntao2000 发表于 2022-11-12 12:09
Sub 组号()
    Dim m&, n&, o&, x&, m1&, m2&, m3&, m4&
    Dim arr, brr1(), brr2(), brr3(), brr4()
...

谢谢，十分感谢。
我回头找到问题所在了。是因为原代码指定的单元格错误，导致VBA改写的单元格内容错误或空白。新VBA读不到数据问题。

yellowhawk

不看你的问题，就代码而言：
Sub 组号()
Dim WD As Worksheet
Set WD = ThisWorkbook.Sheets("排列")
Dim m, n, o, m1, m2, m3, m4, a, b, c, d, a2, b2, c2, d2 As Integer
Dim arr(1 To 4) As String    *这里的arr(1 To 4)对不对？‘‘这里arr(1 to 4)只表示一个一维数组’’
Dim brr1(), brr2(), brr3()    *这里多个BRR（），怎么一笔带过？“这里没有一笔带过之说，只能这样一个个定义”
m = 0
n = 0
  o = 0
m1 = 1
m2 = 1
  m3 = 1
   m4 = 1
a = WD.Range("CR2").Value
b = WD.Range("CS2").Value
  c = WD.Range("CT2").Value
   d = WD.Range("CU2").Value
a2 = a + 2
b2 = b + 2
  c2 = c + 2
   d2 = d + 2
arr1 = WD.Range("CR" & 3 & ":CR" & a2)    *这里的ARR1-4，是用ARR1还是ARR（1）“当然是arr1,arr(1)则是表示数组中的一个值”
arr2 = WD.Range("CS" & 3 & ":CS" & b2)
  arr3 = WD.Range("CT" & 3 & ":CT" & c2)
   arr4 = WD.Range("CU" & 3 & ":CU" & d2)
For m1 = 1 To a
For m2 = 1 To b
  If Right(arr1(m1, 1), 2) = Left(arr2(m2, 1), 2) Then
  m = m + 1
  ReDim Preserve brr1(1 To m)
  brr1(m) = arr1(m1, 1) & Right(arr2(m2, 1), 2)
For m3 = 1 To c
  If Right(brr1(m), 2) = Left(arr3(m3, 1), 2) Then
  n = n + 1
  ReDim Preserve brr2(1 To n)
  brr2(n) = brr1(m) & Right(arr3(m3, 1), 2)
For m4 = 1 To d
  If Right(brr2(n), 2) = Left(arr4(m4, 1), 2) Then
  o = o + 1
  ReDim Preserve brr3(1 To o)
  brr3(o) = brr2(n) & Right(arr4(m4, 1), 2)
End If
Next m4
End If
Next m3
End If
Next m2
Next m1
WD.Range("CV3").Resize(UBound(brr3), 1) = Application.Transpose(brr3)   *总提示这里有错“什么错提示？”
Erase arr1
Erase arr2
Erase arr3     *这里这么多ARR，怎么简短的都清除？，“如果再多则使用循环！只有4句代码差不多”
Erase arr4
Erase brr1()
Erase brr2()    *这里的BRR，怎么简短的清除内存？“如果再多则使用循环！只有3句代码差不多”
Erase brr3()
Dim arr5, arr6, brr4(), brr5()   **这里，因为上面代码运行完，有个函数计算过程，需要将函数计算结果装入ARR，所以在这里才声明的ARR对吧？
    “任何地方申明都可以，一般只在之前申明就行”
Dim x, y As Long
x = 0
y = 1
arr5 = WD.Range("DP3:DP50001")
arr6 = WD.Range("DQ3:DQ50001")
For y = 1 To 49998
If arr5(y, 1) > 0 Then   *或者提示这里有错 “这是错误应该是出在arr5数组的问题”
x = x + 1
ReDim Preserve brr4(1 To x)
ReDim Preserve brr5(1 To x)
brr4(x) = arr5(y, 1)
brr5(x) = arr6(y, 1)
End If
Next y
WD.Range("DS3").Resize(UBound(brr4), 1) = Application.Transpose(brr4)   *这两个可能也有错。 “这是出错应该是brr4数组的问题”
WD.Range("DR3").Resize(UBound(brr5), 1) = Application.Transpose(brr5)
Erase arr5
Erase arr6
Erase brr4()
Erase brr5()
MsgBox ("完毕")
End Sub