据编号将编号方指定位置

xing_chen

老师！有簿，需根据编号前2位数寻找月表中，再将编号放入月表的指定位置，敬请老师赐教。谢谢

3190496160

Sub 分配数据()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("目录")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 3 Then MsgBox "目录为空！": End
    ar = .Range("a1:b" & r)
End With
For i = 3 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        zf = Left(Trim(ar(i, 2)), 2)
        d(zf) = ""
    End If
Next i
For Each k In d.keys
    mc = Val(k) & "月"
    n = 0: xh = 1
    ReDim br(1 To UBound(ar))
    For i = 3 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            zf = Left(Trim(ar(i, 2)), 2)
            If zf = k Then
                n = n + 1
                br(n) = ar(i, 2)
            End If
        End If
    Next i
    With Sheets(mc)
        .Columns(1) = Empty
        For i = 1 To n
            .Cells(xh, 1) = br(i)
            xh = xh + 7
        Next i
    End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

将编号放到指定表格的指定单元格中.rar (16.15 KB, 下载次数: 11)

2023-2-18 10:56 上传

点击文件名下载附件

xing_chen

3190496160 发表于 2023-2-18 10:57

谢谢老师！运行如愿！

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr$(), i&, iPosRow&, dic As Object, vKey
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Sheets(1).[A1].CurrentRegion
    For i = 3 To UBound(ar)
        If ar(i, 1) <> "" Then
            vKey = Val(Left(ar(i, 2), 2)) & "月"
            dic(vKey) = dic(vKey) & "," & i
        End If
    Next i
   
    For Each vKey In dic.keys
        br = Split(dic(vKey), ",")
        ReDim cr(1 To 10 ^ 3, 1 To 1)
        With Sheets(vKey)
            For i = 1 To UBound(br)
                Select Case i
                Case Is = 1
                    iPosRow = 1
                Case Is = 2
                    iPosRow = 8
                Case Is = 3
                    iPosRow = 13
                Case Is = 4
                    iPosRow = 20
                End Select
               cr(iPosRow, 1) = ar(Val(br(i)), 2)
            Next i
            .Cells.Clear
            .[A1].Resize(22) = cr
        End With
    Next
   
    Beep
End Sub

gwjkkkkk

请楼主参考附件。。。

准提部林

間隔7...每月的周數??
所以, 目錄表不會超過一年的總周數.約53行???
那逐一填格, 不用數組也很快的~~

xing_chen

gwjkkkkk 发表于 2023-2-18 12:15
请楼主参考附件。。。

谢谢老师！运行如愿！

xing_chen

准提部林 发表于 2023-2-18 13:12
間隔7...每月的周數??
所以, 目錄表不會超過一年的總周數.約53行???
那逐一填格, 不用數組也很快的~~

谢谢老师！你观察的真仔细。不过实际情况倒与周无关，我这是为下步设置预留的提示。