[已解决][求助]如何使表格按要求填入信息

zjsxzgx

要求一：点击【记录查阅】上的【统计计算】时 根据A2的标示在数据库中查找相应的日期填入A5一下的单元格（不重复填写）

要求二：在【数据库】中找出【记录查阅】A5及A5以下单元格中相同的信息，（强调一下是标示。日期。型号都相同）

然后把【数据库】中对应的出厂属填写到【记录查阅】相同日期行同

rPcSx72X.rar (20.68 KB, 下载次数: 8)

2010-2-3 09:42 上传

点击文件名下载附件
如何使表格按要求填入信息

[此贴子已经被作者于2010-2-3 10:03:18编辑过]

最佳答案

月排行榜 / 总排行榜

amulee

2010-2-3 14:50

看看这个
Private Sub CommandButton2_Click()
    Dim ArrXH, ArrYS, BZ, ArrJG, TempX, TempY
    Dim d As Object, i&, j&, K&
    On Error Resume Next
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Sheet1.Range("A2:D" & Sheet1.Range("A65536").End(xlUp).Row)
    ArrXH = Range("B4:M4")
    BZ = Range("A2")
    ReDim ArrJG(1 To 13, 1 To 1)
    K = 0
    For i = 1 To UBound(ArrYS)
        If ArrYS(i, 1) = BZ Then
            If Not d.exists(ArrYS(i, 3)) Then
                K = K + 1
                ReDim Preserve ArrJG(1 To 13, 1 To K)
                d(ArrYS(i, 3)) = K
                ArrJG(1, K) = ArrYS(i, 3)
            End If
            TempY = d(ArrYS(i, 3))
            TempX = WorksheetFunction.Match(ArrYS(i, 2), ArrXH, 0) + 1
            If Err.Number <> 0 Then
                Err.Clear
            Else
                ArrJG(TempX, TempY) = ArrYS(i, 4) + ArrJG(TempX, TempY)
            End If
        End If
    Next
    Range("A5:M24").ClearContents
    Range("A5").Resize(UBound(ArrJG, 2), 13) = Application.Transpose(ArrJG)
End Sub

跳转到最佳答案楼层

蓝桥玄霜

Private Sub CommandButton2_Click()
Dim i&, Myr&, Myc%, Arr, bs1$, xh1$, rq1
Dim r2, xh$, col%, m%
Application.ScreenUpdating = False
Myr = Sheet1.[a65536].End(xlUp).Row
Arr = Sheet1.Range("a2:d" & Myr)
Myc = Sheet3.[iv4].End(xlToLeft).Column
Range("a5", Cells(24, Myc)).ClearContents
bs1 = [a2].Value
xh1 = [b2].Value
rq1 = [c2].Value
m = 4
For i = 1 To UBound(Arr)
    If Arr(i, 1) = bs1 Then
        xh = Arr(i, 2)
        If xh1 <> "" Then
            If xh1 = xh Then
                If rq1 <> "" Then
                    If rq1 = Arr(i, 3) Then
                        Set r2 = Sheet3.Rows(4).Find(xh, , , 1)
                        If Not r2 Is Nothing Then
                            col = r2.Column
                        Else
                            col = Sheet3.[iv4].End(xlToLeft).Column + 1
                            Cells(4, col) = xh
                        End If
                        m = m + 1
                        Cells(m, 1) = rq1
                        Cells(m, col) = Arr(i, 4)
                    Else
                        GoTo 100
                    End If
                End If
            End If
        End If
    End If
100:
Next
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2010-2-3 13:43:48编辑过]

zjsxzgx

我测试了。没有用   我要的是把数据库的的数据按要求在【记录查阅】汇总

zjsxzgx

谢谢你的帮助。我测试了。貌似没有用。我要的是

如：IF  记录查阅！A2 = 数据库 $ a列 那么 把 数据库 C列的几月几号 写入到【记录查阅】的 A5以下（要求数据部重复）

接下来是把A5以下的 数据与 数据库里核对 并把出厂的数据写入到对应的地方

amulee

看看这个
Private Sub CommandButton2_Click()
    Dim ArrXH, ArrYS, BZ, ArrJG, TempX, TempY
    Dim d As Object, i&, j&, K&
    On Error Resume Next
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Sheet1.Range("A2:D" & Sheet1.Range("A65536").End(xlUp).Row)
    ArrXH = Range("B4:M4")
    BZ = Range("A2")
    ReDim ArrJG(1 To 13, 1 To 1)
    K = 0
    For i = 1 To UBound(ArrYS)
        If ArrYS(i, 1) = BZ Then
            If Not d.exists(ArrYS(i, 3)) Then
                K = K + 1
                ReDim Preserve ArrJG(1 To 13, 1 To K)
                d(ArrYS(i, 3)) = K
                ArrJG(1, K) = ArrYS(i, 3)
            End If
            TempY = d(ArrYS(i, 3))
            TempX = WorksheetFunction.Match(ArrYS(i, 2), ArrXH, 0) + 1
            If Err.Number <> 0 Then
                Err.Clear
            Else
                ArrJG(TempX, TempY) = ArrYS(i, 4) + ArrJG(TempX, TempY)
            End If
        End If
    Next
    Range("A5:M24").ClearContents
    Range("A5").Resize(UBound(ArrJG, 2), 13) = Application.Transpose(ArrJG)
End Sub