数据归纳汇总

CYZ凡星点点 · 发表于 2024-2-9 21:05

fzxba 发表于 2024-2-9 18:00

运行出现错误

CYZ凡星点点 · 发表于 2024-2-9 21:14

ykcbf1100 发表于 2024-2-9 20:59
你求助时应该说清楚。我在写代码时就卡在那里了，就没往下写。

抱歉，我只是想把C列-E列当整体复制，在根据姓名和C列日期时间，判断总单（资料）有没有重复，
D列只是支付和未支付的函数判断求和条件。

fzxba · 发表于 2024-2-9 21:14

CYZ凡星点点发表于 2024-2-9 21:05
运行出现错误

WPS不行
Excel不完整安装不行
测试成功才发的，是不会装13的……
实在不行算了。

CYZ凡星点点 · 发表于 2024-2-9 21:18

fzxba 发表于 2024-2-9 21:14
WPS不行
Excel不完整安装不行
测试成功才发的，是不会装13的……

哦，WPS在不同工作簿之间切换复制比较方便，我一直就用WPS

fzxba · 发表于 2024-2-9 21:20

CYZ凡星点点发表于 2024-2-9 21:18
哦，WPS在不同工作簿之间切换复制比较方便，我一直就用WPS

你不标注 Office版本 2007-2013 ，我是不会写的。

CYZ凡星点点 · 发表于 2024-2-9 21:30

fzxba 发表于 2024-2-9 21:20
你不标注 Office版本 2007-2013 ，我是不会写的。

我用WPS2013版，Office版本2007-2013 用过很不方便使用，我有个工作簿专门放公式资料的，在新建工作簿时直接打开资料，复制WPS比较快捷方便。

fzxba · 发表于 2024-2-10 07:53

Sub test3() '不用SQL获取数据
Dim strFile As String
strFile = ThisWorkbook.Path & "\信息.xlsm"
If Dir(strFile) = "" Then MsgBox strFile & " 文件不存在！", 64: Exit Sub
Application.ScreenUpdating = False
Dim ar, br, cr() As Long, Dict As Object
Dim i As Long, j As Long, pos As Long, iMax As Long
iMax = 366
With Range("A1").CurrentRegion
ar = Application.Rept(.Rows(2), 1)
br = .Offset(2).Resize(iMax)
ReDim cr(1 To UBound(ar))
End With
Set Dict = CreateObject("Scripting.Dictionary")
For j = 1 To UBound(ar) Step 3
Dict.Add ar(j), j
cr(j) = Cells(1, j).End(xlDown).Row - 2
br(iMax, j) = "|"
For i = 1 To cr(j)
br(iMax, j) = br(iMax, j) & br(i, j) & "|" & br(i, j + 1) & "|" & br(i, j + 2) & "|"
Next
Next
With Workbooks.Open(strFile, False)
ar = .Worksheets("单价").Range("A1").CurrentRegion.Offset(, 1).Resize(, 4)
.Close False
End With
For i = 2 To UBound(ar)
If Dict.Exists(ar(i, 1)) Then
pos = Dict(ar(i, 1))
If InStr(br(iMax, pos), "|" & ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4) & "|") = 0 Then
cr(pos) = cr(pos) + 1
For j = 2 To UBound(ar, 2)
br(cr(pos), pos + j - 2) = ar(i, j)
br(iMax, pos) = br(iMax, pos) & ar(i, j) & "|"
Next
End If
End If
Next
Range("A13").Resize(WorksheetFunction.Max(cr), UBound(br, 2)) = br '改为 Range("A3")
Set Dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

3190496160 · 发表于 2024-2-10 11:11

Sub 汇总信息()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "信息.xlsm")
If f = "" Then MsgBox "找不到信息.xlsm文件！": End
Set wb = Workbooks.Open(lj & f, 0)
ar = wb.Worksheets("单价").[a1].CurrentRegion
wb.Close False
With Sheets("资料")
y = .Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To y Step 3
      rs = .Cells(Rows.Count, j).End(xlUp).Row
      If rs >= 3 Then
         br = .Range(.Cells(2, j), .Cells(rs, j))
         For i = 2 To UBound(br)
            zd = br(1, 1) & "|" & br(i, 1)
            dc(zd) = ""
         Next i
      End If
      d(.Cells(2, j).Value) = j
Next j
For i = 2 To UBound(ar)
      If ar(i, 2) <> "" Then
         lh = d(ar(i, 2))
         If lh <> "" Then
            zd = ar(i, 2) & "|" & ar(i, 3)
            If Not dc.exists(zd) Then
                  k = k + 1
                  r = .Cells(Rows.Count, lh).End(xlUp).Row + 1
                  m = lh - 1
                  For j = 3 To 5
                     m = m + 1
                     .Cells(r, m) = ar(i, j)
                  Next j
            End If
         End If
      End If
Next i
End With
Application.ScreenUpdating = True
If k <> "" Then
MsgBox "更新了" & k & "行数据！"
Else
MsgBox "没有可更新的数据！"
End If
End Sub

3190496160 · 发表于 2024-2-10 11:12

增加了姓名日期判断，供参考

文件夹.rar (263.01 KB, 下载次数: 24)

CYZ凡星点点 · 发表于 2024-2-10 22:02

在此非常感谢3190496160和fzxba两位老师的帮助！还有18楼3190496160老师后面增加的提示信息更加完美，我也没有想到

		自动登录	找回密码
密码			免费注册

[求助] 数据归纳汇总

评分

评分

评分

评分