VBA如何制作表格录制问题

rayhen

根据输入资料按下确定就会填写到SHEET2

输入地点跟销售量
输入日期

任何帮助，将不胜感激！

3190496160

刚刚求助的是查询，咋又变成录入了呢？？？？？

rayhen

老师这两种情况都会发生跟用的上(因为是不同部门),请再帮忙,

不知道为什么

can kao ..........

3190496160

Sub 录入()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
    r = .Cells(Rows.Count, 3).End(xlUp).Row
    If r < 4 Then MsgBox "请输入数据！": End
    ar = .Range("c4:d" & r)
    rq = .[c2]
End With
With Sheet2
    rs = .Cells(Rows.Count, 2).End(xlUp).Row + 1
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    br = .Range(.Cells(2, 2), .Cells(rs, y))
    For j = 2 To UBound(br, 2)
        If Trim(br(1, j)) <> "" Then
            d(Trim(br(1, j))) = j
        End If
    Next j
    xh = UBound(br)
    For i = 1 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            lh = d(Trim(ar(i, 1)))
            If lh <> "" Then
                br(xh, lh) = ar(i, 2)
            End If
        End If
    Next i
    br(xh, 1) = rq
    .Range(.Cells(2, 2), .Cells(rs, y)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

20230502.rar (13.46 KB, 下载次数: 8)

2023-5-2 11:29 上传

点击文件名下载附件

rayhen

不知道为什么 发表于 2023-5-2 10:56
can kao ..........

老师,打开您提供的附件代码不见了

rayhen

感谢老师热心帮忙问题解决了

z865593849

Sub a()
If Sheets(2).Columns(2).Find(DateValue(Sheets(1).[c2])) Is Nothing Then
    Sheets(2).[b2].End(xlDown).Offset(1, 0) = Sheets(1).[c2]
End If
Dim x1, y1, x2, y2
For x1 = 4 To Sheets(1).Cells(4, 3).End(xlDown).Row
    x2 = Sheets(2).Columns(2).Find(DateValue(Sheets(1).[c2])).Row '查找日期所在行
    '判断城市是否存在
    If Sheets(2).Rows(2).Find(Sheets(1).Cells(x1, 3)) Is Nothing Then
        Sheets(2).[b2].End(xlToRight).Offset(0, 1) = Sheets(1).Cells(x1, 3)
    End If
    y2 = Sheets(2).Rows(2).Find(city).Column '查找城市所在列
    Sheets(1).Cells(x1, 4).Copy Sheets(2).Cells(x2, y2)
Next

End Sub