按要求填列数据

lbhlbh

liulang0808 发表于 2024-12-11 08:55
因为你后面表格的每个区域列数不一样的，更新了下

谢谢谢谢。现在还是只对A1和A4区域起作用呢，其他的都没反应呢。不好意思 ，再将每个区域列数设置是一样的（都是8列），请你再帮帮修改下:

Sub 未上报()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据库").UsedRange
    dt = CDate([b19])
    For j = 4 To UBound(arr)
        If Len(arr(j, 20)) > 0 And Val(arr(j, 10)) > 0 And CDate(arr(j, 1)) = dt Then
            k = arr(j, 20)
            If Not d.exists(k) Then
                Set d(k) = CreateObject("scripting.dictionary")
            End If
            d(k)(j) = j
        End If
    Next j
   
    For j = 2 To Cells(3, Columns.Count).End(xlToLeft).Column
        k = Cells(3, j).Value
        If Len(k) > 0 Then
            If d.exists(k) Then
                If d(k).Count >= 12 Then
                    r = 5: c = j
                    For Each x In d(k).keys
                        Cells(r, c) = arr(x, 3)
                        Cells(r, c + 1) = arr(x, 4)
                        r = r + 1
                        If r = 17 Then
                            r = 5: c = c + 2
                        End If
                    Next x
                End If
            End If
        End If
    Next j
   
End Sub

。非常谢谢了

lbhlbh

liulang0808 发表于 2024-12-11 08:55
因为你后面表格的每个区域列数不一样的，更新了下

还是只对A1、A4起作用，其他的都没反应呢。不好意思，现将各区域的列数都设置8列，请你再帮帮我修改下，：Sub 未上报()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据库").UsedRange
    dt = CDate([b19])
    For j = 4 To UBound(arr)
        If Len(arr(j, 20)) > 0 And Val(arr(j, 10)) > 0 And CDate(arr(j, 1)) = dt Then
            k = arr(j, 20)
            If Not d.exists(k) Then
                Set d(k) = CreateObject("scripting.dictionary")
            End If
            d(k)(j) = j
        End If
    Next j
   
    For j = 2 To Cells(3, Columns.Count).End(xlToLeft).Column
        k = Cells(3, j).Value
        If Len(k) > 0 Then
            If d.exists(k) Then
                If d(k).Count >= 12 Then
                    r = 5: c = j
                    For Each x In d(k).keys
                        Cells(r, c) = arr(x, 3)
                        Cells(r, c + 1) = arr(x, 4)
                        r = r + 1
                        If r = 17 Then
                            r = 5: c = c + 2
                        End If
                    Next x
                End If
            End If
        End If
    Next j
  End Sub
看能不能达到要求。非常谢谢。