组合分解

lljd808

运行时总是提示：

vba运行时错误'424' 要求对象 或简单只提示：要求对象，却找到不原因，请高手指点，谢谢！

excel玉米

抄作业的时候，是从图片中提取文字，所以，Sheet1.Activate  抄成了sheetl  
还有 Set RegEx = CreateObject("VBSCRIPT.REGEXP") 'RegEx为建立正则表达式  
里面的 CreateObject  O抄成了0  ，诸如此类。请楼主认真检查作业。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. Crr = Sheet1.Range("e1").CurrentRegion.Value
   
6. For j = 2 To UBound(Crr, 2)
   
7.     dic(Crr(1, j)) = j
   
8. Next
   
9. k = dic.keys
   
10. m2 = dic.items
    
11. ReDim Brr(1 To UBound(arr), 1 To 7)
    
12. For i = 2 To UBound(arr)
    
13.     ar = Split(arr(i, 2), ".")
    
14.     Brr(i, 1) = ar(0) & "班"
    
15.     b = VBA.Replace(ar(1), "人", "，")
    
16.     br = Split(b, "，")
    
17.     For Z = LBound(br) To UBound(br)
    
18.         If Len(br(Z)) > 0 Then
    
19.             x = Left(br(Z), 3)
    
20.             For ii = 1 To 3
    
21.                 x2 = Mid(x, ii, 1)
    
22.                 cl = dic(x2)
    
23.                
    
24.                 y = Val(Mid(br(Z), 4))
    
25.                 Brr(i, cl) = Brr(i, cl) + y
    
26.             Next
    
27.         End If
    
28.    Next Z
    
29. Next
    
30. Sheet1.Range("e1").Resize(UBound(arr), 7) = Brr
    
31. Sheet1.Range("e1").Resize(1, 7) = Crr
    
32. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试........

longwin

第一步：
Sub zh1()
Arr = Sheet1.[a1].CurrentRegion
Sheet1.[e2].Resize(UBound(Arr) - 1, 7) = ""
Brr = Sheet1.[e1].Resize(UBound(Arr), 7)
Set d = CreateObject("scripting.dictionary")
For i = 2 To 7
    d(Brr(1, i)) = i
Next
For i = 2 To UBound(Arr)
    s = Split(Arr(i, 2), ".")(1)
    ss = Split(s, "，")
    Brr(i, 1) = Arr(i, 1) & "班"
    For m = 0 To UBound(ss)
        sss = ss(m)
        rs = ""
         For k = 1 To Len(sss)
            If IsNumeric(Mid(sss, k, 1)) Then rs = rs & Mid(sss, k, 1)
         Next
        For k = 1 To 3
            xk = Mid(sss, k, 1)
            Brr(i, d(xk)) = Brr(i, d(xk)) + Val(rs)
        Next
    Next
Next
Sheet1.[e1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Set d = Nothing
End Sub

quqiyuan

参与一下，仅供参考。。。
写了第一个功能，第二个好像组合太多变化了吧，
使用了楼主的正则自定义函数。

quqiyuan

代码如下。。。。
Function ss(rng)
    Dim RegEx, b, bb
    Set RegEx = CreateObject("VBScript.RegExp") 'Create0bject("VBSCRIPT.REGEXP")                'RegEx为建立正则表达式
    RegEx.Global = True                                        '设置全局可用
    RegEx.Pattern = "\D"
    b = RegEx.Replace(rng, "|")                                '把匹配样式的字符用|替换
    ss = Replace(b, "|", "")                                   '数字
    Set RegEx = Nothing
End Function
   
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    With sht
    Arr = .[a1].CurrentRegion
    Set d = CreateObject("Scripting.Dictionary")
    Ar = [{"历","政","地","物","化","生"}]
    For i = 2 To UBound(Arr)
        d(Arr(i, 1)) = i
    Next
    For i = 1 To UBound(Ar)
        d(Ar(i)) = i + 1
    Next
    ReDim Brr(1 To UBound(Arr), 1 To UBound(Ar) + 1)
    For i = 2 To UBound(Arr)
        s = Split(Arr(i, 2), ".")(1)
        If InStr(s, "，") = 0 Then
            sss = Left(s, 3)
            ssss = --ss(s)
            For j = 1 To 3
                If d.exists(Mid(s, j, 1)) Then
                    Brr(d(Arr(i, 1)), d(Mid(s, j, 1))) = ssss
                End If
            Next
        Else
            s = Split(Split(Arr(i, 2), ".")(1), "，")
            For j = 0 To UBound(s)
                sss = Left(s(j), 3)
                ssss = --ss(s(j))
                For k = 1 To 3
                    If d.exists(Mid(s(j), k, 1)) Then
                        Brr(d(Arr(i, 1)), d(Mid(s(j), k, 1))) = Brr(d(Arr(i, 1)), d(Mid(s(j), k, 1))) + ssss
                    End If
                Next
            Next
        End If
    Next
    .[m1].CurrentRegion.Clear
    .[m1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    .[n1].Resize(, UBound(Ar)) = Ar
    ReDim br(1 To UBound(Arr))
    For i = 1 To UBound(Arr)
        br(i) = Arr(i, 1) & "班"
    Next
    .[m1].Resize(UBound(Arr)) = Application.Transpose(br)
    .[m1] = "学科"
    .[m1].CurrentRegion.HorizontalAlignment = xlCenter
    .[m1].CurrentRegion.Borders.LineStyle = 1
    .[m1].CurrentRegion.Columns.ColumnWidth = 8.38
    End With
    Set d = Nothing
    Beep
End Sub

lljd808

excel玉米 发表于 2024-11-16 21:08
抄作业的时候，是从图片中提取文字，所以，Sheet1.Activate  抄成了sheetl  
还有 Set RegEx = CreateObje ...

多谢指点！

lljd808

quqiyuan 发表于 2024-11-16 22:14
参与一下，仅供参考。。。
写了第一个功能，第二个好像组合太多变化了吧，
使用了楼主的正则自定义函数。 ...

多谢指点！