ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1910|回复: 12

[求助] 求助高手修改VBA代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-7-8 18:17 | 显示全部楼层 |阅读模式
本帖最后由 510437958 于 2016-7-8 20:29 编辑

再次非常感谢准提部林老师和三无(沉迷)帅哥的帮助,可是两位老师很难联系上,所以希望他们有机会看到或别的老师看到了愿意尝试修改一下代码,谢谢!
先附上准提老师的代码(排名不分先后)
Private Sub CommandButton1_Click()
UsedRange.Offset(2).ClearContents
rw = Sheets("数据源").[ap65536].End(3).Row
ReDim ar(1 To rw, 1 To 38)
Set d = CreateObject("Scripting.Dictionary")
m = -2
For i = 4 To rw
   If Sheets("数据源").Cells(i, 42) <> "" Then
      Set x = Range("f2:al2").Find(Sheets("数据源").Cells(i, 3), , , 1)
      If x Is Nothing Then
         GoTo 500
      Else
         l = x.Column
      End If
      s1 = Format(Sheets("数据源").Cells(i, 34), "yyyy年m月")
      s2 = Sheets("数据源").Cells(i, 66) & "(" & Sheets("数据源").Cells(i, 42) & ")"
      s = s1 & s2
      If Not d.Exists(s) Then
         m = m + 3
         d(s) = m
         ar(m, 1) = s1
         ar(m, 2) = "征收"
         ar(m, 3) = s2
         ar(m + 1, 1) = s1
         ar(m + 1, 2) = "入库"
         ar(m + 1, 3) = s2
         ar(m + 2, 1) = s1
         ar(m + 2, 2) = "在途"
         ar(m + 2, 3) = s2
         If Sheets("数据源").Cells(i, 54) <> "" Then
            If l > 24 Then
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 24) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 24) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, l) = Sheets("数据源").Cells(i, 9)
            Else
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 5) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 5) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, l) = Sheets("数据源").Cells(i, 9)
            End If
         Else
            If l > 24 Then
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 24) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 24) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, l) = Sheets("数据源").Cells(i, 9)
            Else
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 5) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 5) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, l) = Sheets("数据源").Cells(i, 9)
            End If
         End If
       Else
          If Sheets("数据源").Cells(i, 54) <> "" Then
            If l > 24 Then
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 4) = ar(d(s) + 1, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 24) = ar(d(s), 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 24) = ar(d(s) + 1, 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, l) = ar(d(s) + 1, l) + Sheets("数据源").Cells(i, 9)
            Else
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 4) = ar(d(s) + 1, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 5) = ar(d(s), 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 5) = ar(d(s) + 1, 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, l) = ar(d(s) + 1, l) + Sheets("数据源").Cells(i, 9)
            End If
         Else
            If l > 24 Then
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 4) = ar(d(s) + 2, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 24) = ar(d(s), 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 24) = ar(d(s) + 2, 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, l) = ar(d(s) + 2, l) + Sheets("数据源").Cells(i, 9)
            Else
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 4) = ar(d(s) + 2, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 5) = ar(d(s), 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 5) = ar(d(s) + 2, 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, l) = ar(d(s) + 2, l) + Sheets("数据源").Cells(i, 9)
            End If
         End If
        End If
      End If
500:
Next
If m > 0 Then
   [a3].Resize(m + 2, 38) = ar
   MsgBox "已统计结果!"
End If
End Sub


代码对BN列街道乡镇进行了重复排错,只限定第一个乡镇和公司数据,所以导致总数对不上,比如腾飞镇有可能对应二公司、也有可能对应3公司等。

顺便解释一下:AH列不为空表示征收数,BB列部位空表示入库数,差额为在途数,BN列+(AP列数据)组合计算当月征收、入库、在途数,分不同产品

20160517VBA (1).rar

6.71 KB, 下载次数: 12

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-8 18:19 | 显示全部楼层
再附上三无帅哥的代码
Private Sub CommandButton1_Click()
UsedRange.Offset(2).ClearContents
rw = Sheets("数据源").[ap65536].End(3).Row
ReDim ar(1 To rw, 1 To 38)
Set d = CreateObject("Scripting.Dictionary")
m = -2
For i = 4 To rw
   If Sheets("数据源").Cells(i, 42) <> "" Then
      Set x = Range("f2:al2").Find(Sheets("数据源").Cells(i, 3), , , 1)
      If x Is Nothing Then
         GoTo 500
      Else
         l = x.Column
      End If
      s1 = Format(Sheets("数据源").Cells(i, 34), "yyyy年m月")
      s2 = Sheets("数据源").Cells(i, 66) & "(" & Sheets("数据源").Cells(i, 42) & ")"
      s = s1 & s2
      If Not d.Exists(s) Then
         m = m + 3
         d(s) = m
         ar(m, 1) = s1
         ar(m, 2) = "征收"
         ar(m, 3) = s2
         ar(m + 1, 1) = s1
         ar(m + 1, 2) = "入库"
         ar(m + 1, 3) = s2
         ar(m + 2, 1) = s1
         ar(m + 2, 2) = "在途"
         ar(m + 2, 3) = s2
         If Sheets("数据源").Cells(i, 54) <> "" Then
            If l > 24 Then
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 24) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 24) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, l) = Sheets("数据源").Cells(i, 9)
            Else
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 5) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, 5) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 1, l) = Sheets("数据源").Cells(i, 9)
            End If
         Else
            If l > 24 Then
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 24) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 24) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, l) = Sheets("数据源").Cells(i, 9)
            Else
               ar(m, 4) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 4) = Sheets("数据源").Cells(i, 9)
               ar(m, 5) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, 5) = Sheets("数据源").Cells(i, 9)
               ar(m, l) = Sheets("数据源").Cells(i, 9)
               ar(m + 2, l) = Sheets("数据源").Cells(i, 9)
            End If
         End If
       Else
          If Sheets("数据源").Cells(i, 54) <> "" Then
            If l > 24 Then
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 4) = ar(d(s) + 1, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 24) = ar(d(s), 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 24) = ar(d(s) + 1, 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, l) = ar(d(s) + 1, l) + Sheets("数据源").Cells(i, 9)
            Else
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 4) = ar(d(s) + 1, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 5) = ar(d(s), 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, 5) = ar(d(s) + 1, 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 1, l) = ar(d(s) + 1, l) + Sheets("数据源").Cells(i, 9)
            End If
         Else
            If l > 24 Then
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 4) = ar(d(s) + 2, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 24) = ar(d(s), 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 24) = ar(d(s) + 2, 24) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, l) = ar(d(s) + 2, l) + Sheets("数据源").Cells(i, 9)
            Else
               ar(d(s), 4) = ar(d(s), 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 4) = ar(d(s) + 2, 4) + Sheets("数据源").Cells(i, 9)
               ar(d(s), 5) = ar(d(s), 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, 5) = ar(d(s) + 2, 5) + Sheets("数据源").Cells(i, 9)
               ar(d(s), l) = ar(d(s), l) + Sheets("数据源").Cells(i, 9)
               ar(d(s) + 2, l) = ar(d(s) + 2, l) + Sheets("数据源").Cells(i, 9)
            End If
         End If
        End If
      End If
500:
Next
If m > 0 Then
   [a3].Resize(m + 2, 38) = ar
   MsgBox "已统计结果!"
End If
End Sub

三无帅哥的代码对AH列进行了完全对应由于AH开票时间精确到秒,所以导致出现同一街道乡镇和公司的组合出现多行征收和入库数。因此对AH列无需比对,只提取YYYY-MM即2016年06月格式即可

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-8 18:22 | 显示全部楼层
希望准提老师和三无帅哥有机会看到,或者别的老师看到能帮我修改完善一下,谢谢!我爱论坛,话说EXCELHOME论坛最不友好的就是登陆,我从周一登陆到现在,最后还是通过邮箱申请修改密码登陆。通过微博问了博主,总说要我更换浏览器,我从火狐、百度到IE基本上转了一圈,最后还是登不上,希望论坛改进这点最好。

TA的精华主题

TA的得分主题

发表于 2016-7-10 06:37 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-10 16:15 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lsc900707 发表于 2016-7-10 06:37
看了半天,两个代码是一样的吧?

不一样的。首先准提老师的代码的问题在于假设腾飞镇同时对应了三公司和四公司,则代码返回的结果只有腾飞镇(三公司),没有腾飞镇(四公司),导致总数对不上;三无(沉迷)帅哥的代码则是总数对的上,但是是按每笔收入系统显示说的开具日期暨AH列来分类,产生的问题在于假设腾飞镇(三公司)在当月有3笔收入,且3笔收入AH显示的时间不一致,就会导致不能合并当月收入,只会把一行数据拆分成3行数据,原来的3比收入对应3行,现在回对应成9行,而不是1行;不知道我这样说是否清楚了。谢谢lsc900707老师的关注,如果您能修改完善一下就更好了。

TA的精华主题

TA的得分主题

发表于 2016-7-10 17:14 | 显示全部楼层
经再次核对检查,两个代码一模一样。你再核对一次看看,是不是贴错一个?

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-10 17:20 | 显示全部楼层
lsc900707 发表于 2016-7-10 17:14
经再次核对检查,两个代码一模一样。你再核对一次看看,是不是贴错一个?

已经崩溃的我不得不承认是贴错了,谢谢lsc900707老师的提醒,也向准提老师和三无(沉迷)帅哥致歉。

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-10 17:59 | 显示全部楼层
这才是准提老师的代码,再次致歉,并感谢lsc900707老师的提醒

Sub TEST()
Dim xD, A As Range, C%, ClmnCunt%, TL1%, TL2%
Set xD = CreateObject("Scripting.Dictionary")
With Sheets("VBA").UsedRange
  .Offset(2, 0).EntireRow.Delete '清除原資料
  For Each A In .Rows(2).Cells '第2行標題(事先須手動輸入)
    C = A.Column
    If A <> "" Then xD(A.Value) = C '記錄〔產品〕所在〔列號〕
    If A = "Total" Then If TL1 = 0 Then TL1 = C Else TL2 = C '記錄〔合計〕的〔列號〕
  Next
  ClmnCunt = .Columns.Count '〔列〕總數
End With

Dim Arr, Brr, i&, j%, D(2), T$, R&, N&, U%
Arr = Sheets("Sheet1").UsedRange
ReDim Brr(1 To UBound(Arr), 1 To ClmnCunt)
For i = 4 To UBound(Brr)
  D(0) = Arr(i, [AH1].Column) '開具日期
  D(1) = Arr(i, [BB1].Column) '入庫日期
  If D(0) = "" And D(1) = "" Then GoTo 101
  D(2) = IIf(D(0) = "", D(1), D(0))
  C = xD(Arr(i, 3)): If C = 0 Then GoTo 101 '取得〔產品〕列號
  U = IIf(C > TL2, TL2, TL1) '取得〔合計〕列號

  T = Arr(i, [BN1].Column) & "(" & Arr(i, [AP1].Column) & ")" '〔鄉鎮.公司〕名稱
  R = xD(T)
  If R = 0 Then xD(T) = N + 1: R = N + 1: N = N + 3

  For j = 0 To 2
    Brr(R + j, 1) = Format(Split(D(2) & " ", " ")(0), "yyyy/m/1")
    Brr(R + j, 2) = Array("A", "B", "C")(j) 'A〔征收〕,B〔入庫〕.C〔在途〕
    Brr(R + j, 3) = T
    If j < 2 And D(j) <> "" Then
      Brr(R + j, C) = Brr(R + j, C) + Arr(i, [I1].Column) '產品數量
      Brr(R + j, U) = Brr(R + j, U) + Arr(i, [I1].Column) '合計數量
      Brr(R + j, 4) = Brr(R + j, 4) + Arr(i, [I1].Column) '總計數量
    End If
  Next

  Brr(R + 2, C) = Brr(R, C) - Brr(R + 1, C) '在途產品數量
  Brr(R + 2, U) = Brr(R, U) - Brr(R + 1, U) '在途合計數量
  Brr(R + 2, 4) = Brr(R, 4) - Brr(R + 1, 4) '在途總計數量
101: Next i

If N = 0 Then Exit Sub
With Sheets("VBA").[A3].Resize(N, ClmnCunt)
  .Value = Brr
  .Replace 0, "", Lookat:=xlWhole
  .Borders.LineStyle = 1
End With
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-7-10 20:53 | 显示全部楼层
lsc900707 发表于 2016-7-10 17:14
经再次核对检查,两个代码一模一样。你再核对一次看看,是不是贴错一个?

谢谢您的提醒,已经重新上了代码,期待您的回复。谢谢!

TA的精华主题

TA的得分主题

发表于 2016-7-10 21:14 | 显示全部楼层
我对字典和数组学习不够,这个忙恐怕帮不了。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 05:28 , Processed in 0.051882 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表