|
楼主 |
发表于 2018-12-21 14:54
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
香川群子老师帮我改一下代码
下面代码是以5个为一组进行组合的,怎么改成6个啊?改哪些?写出修改后的代码
- Sub ZHX() '可选择是否保留重复组合,方便写入工作表(允许多列)或导出到记事本
- Dim a(), a1(), b1(), c(101 To 9999) As String, c1(), c2(), c3(), c4()
- On Error Resume Next
- Erase c
- Application.ScreenUpdating = False
- tms = Timer
- Set rng = Selection.SpecialCells(xlCellTypeConstants, 3) '筛选区域内只含数字和文本的单元格
- 'xlNumbers 1;xlTextValues 2;xlLogical 4;xlErrors 16
- 'Cells(1, "a").Select
- If Selection.Count = 1 Then Set rng = Range(Selection.Address) '当只选一个单元格的时候
- ReDim a(rng.Count)
- For Each cell In rng
- T = Trim(cell.Value)
- If T <> "" Then
- If InStr(T, " ") > 0 Then '0值表示没找到双空格
- Do
- i = InStr(T, " ")
- L = Left(T, i - 1)
- R = Mid(T, i + 1)
- T = L & R
- Loop Until InStr(T, " ") = 0
- End If
- s = s + 1
- a(s) = T
- n = n + Application.Combin(UBound(Split(a(s), " ")) + 1, 5)
- End If
- Next
- ReDim c3(1 To n)
- For i = 1 To s
- b = Split(a(i), " ")
- n1 = UBound(b) + 1
- ReDim a1(1 To n1), b1(1 To n1)
- For i1 = 1 To n1
- a1(i1) = --b(i1 - 1)
- Next i1
- For i1 = 1 To n1
- b1(i1) = Format(Application.Small(a1, i1), "00")
- Next i1
- For i1 = 1 To n1 - 4
- For i2 = i1 + 1 To n1 - 3
- For i3 = i2 + 1 To n1 - 2
- For i4 = i3 + 1 To n1 - 1
- For i5 = i4 + 1 To n1
- If n <= Rows.Count Then '若要允许多列就把此行代码改为"If n <= 1 Then"
- kz = b1(i1) & " " & b1(i2) & " " & b1(i3) & " " & b1(i4) & " " & b1(i5)
- j = j + 1
- c3(j) = kz
- Else
- k = --(b1(i1) & b1(i2))
- kz = b1(i3) & b1(i4) & b1(i5)
- If c(k) = "" Then
- c(k) = kz
- Else '若要去除重复组合此行代码改为"ElseIf InStr(c(k), kz) = 0 Then",并改上、下方的代码允许多列
- c(k) = c(k) & "," & kz
- End If
- End If
- Next i5
- Next i4
- Next i3
- Next i2
- Next i1
- Next i
- If n <= Rows.Count Then '若要允许多列就把此行代码改为"If n <= 1 Then"
- With Sheets("Sheet2")
- .Cells.ClearContents
- .Cells(1, 1).Resize(UBound(c3), 1) = Application.Transpose(c3)
- .Columns(1).Sort Key1:=.Range("A1")
- 'Call JSB(c3) '此代码将组合数据导出到记事本
- End With
- Else
- For i = 101 To 9999
- If c(i) <> "" Then
- b2 = Split(c(i), ",")
- n2 = UBound(b2) + 1
- ReDim c1(1 To n2), c2(1 To n2)
- For i2 = 1 To n2
- c1(i2) = --b2(i2 - 1)
- Next i2
- For i2 = 1 To n2
- c2(i2) = Format(Application.Small(c1, i2), "000000")
- T = Format(i, "0000") & c2(i2)
- n3 = n3 + 1
- c3(n3) = Left(T, 2) & " " & Mid(T, 3, 2) & " " & Mid(T, 5, 2) & " " & Mid(T, 7, 2) & " " & Right(T, 2)
- Next i2
- Erase b2
- End If
- Next i
- If n3 <= Rows.Count Then
- Sheets("Sheet2").Cells(1, 1).Resize(n3, 1) = Application.Transpose(c3)
- Else
- ReDim c4(1 To Rows.Count, 1 To n3 \ Rows.Count + 1)
- For i3 = 1 To n3 \ Rows.Count + 1
- For i4 = 1 To Rows.Count
- m = m + 1
- c4(i4, i3) = c3(m)
- If m = n3 Then Exit For
- Next i4
- Next i3
- 'Sheets("Sheet2").Cells.ClearContents
- Sheets("Sheet2").Cells(1, 1).Resize(UBound(c4, 1), UBound(c4, 2)) = c4
- End If
- Call JSB(c3) '此代码将组合数据导出到记事本
- End If
- Application.ScreenUpdating = True
- MsgBox Format(Timer - tms, "0.00s")
- End Sub
- Sub JSB(d)
- Set fs = CreateObject("scripting.filesystemobject")
- Set f = fs.opentextfile(ActiveWorkbook.Path & "\数据导出.txt", 2, True)
- For i = 1 To UBound(d) + 1
- f.writeline d(i)
- Next i
- f.Close
- End Sub
复制代码 |
|