MSCBSC 移动通信论坛
搜索
登录注册
网络优化工程师招聘专栏 4G/LTE通信工程师最新职位列表 通信实习生/应届生招聘职位

  • 阅读:2054
  • 回复:1
excelvba源码
theseu
高级会员
鎵嬫満鍙风爜宸查獙璇


 发短消息    关注Ta 

积分 1463
帖子 181
威望 6127 个
礼品券 8 个
专家指数 -57
注册 2009-5-27
专业方向  移动通信工程设计
回答问题数 0
回答被采纳数 0
回答采纳率 0%
 
发表于 2013-01-10 19:53:02  只看楼主 
【资料名称】:excelvba源码

【资料作者】:calc

【资料日期】:2012-12-12

【资料语言】:中文

【资料格式】:DOC

【资料目录和简介】:

此源码主要是完成两个sheet合并,构思巧妙,值得学习,各位学友帮顶!
Sub Update_Record()
dogg
If Not CheckRTC Then
Exit Sub
End If '20060605 cuihuaran

'根据最新的数据自动更新原始数据,条件是两表格表头的关键字一致
Dim col() As Integer, kcol(1 To 10) As Integer, kstr(1 To 10) As String
'选项
FrmUpdate.Show
Do
DoEvents
If ActiveCon > 1 Then Columns(Selection.Column).Select
If ActiveCon = 4 Then
FrmUpdate.Hide
Exit Do
End If
Loop
DoEvents

Rawdata.Copy after:=Rawdata
Set Rawdata = ActiveSheet
Rawdata.Parent.Windows(1).Visible = False
Newdata.Parent.Windows(1).Visible = False
Set pbar = F1.PBar1
F1.Show
F1.Caption = "Update Record"
pbar.Max = 75
pbar.Value = 1

'********************************************************************************检查索引唯一性
Rawdata.Activate
i = 1: flag1 = 0
Do Until cells(1, i) = "" Or flag1 = 1
If LCase(cells(1, i)) = index Then
flag1 = 1
index_raw = i
End If
i = i + 1
Loop
Newdata.Activate
i = 1: flag2 = 0
Do Until cells(1, i) = "" Or flag2 = 1
If LCase(cells(1, i)) = index Then
flag2 = 1
index_new = i
End If
i = i + 1
Loop
If flag1 * flag2 = 0 Then
F1.Hide
MsgBox "The index are not in both sheet!"
Application.DisplayAlerts = False
Rawdata.Parent.Windows(1).Visible = True
Rawdata.Delete
Application.DisplayAlerts = True
Newdata.Parent.Windows(1).Visible = True
End
End If '检查是否存在索引
DoEvents
pbar.Value = 2
Workbooks.add
Set TmpSheet = ActiveSheet
ActiveWorkbook.Windows(1).Visible = False
Newdata.Columns(index_new).Copy
TmpSheet.Activate
cells(1, 1).Select
ActiveSheet.Paste
Columns(1).Sort key1:=cells(2, 1), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
DoEvents
pbar.Value = 3
i = 2: Flag = 0: n = 2
cells(1, 2) = "Not Unique"
Range("a1,b1").Interior.ColorIndex = 15
Do Until cells(i, 1) = ""
If cells(i, 1) = cells(i + 1, 1) Then
Flag = Flag + 1
If cells(n - 1, 2) <> cells(i, 1) Then
cells(n, 2) = cells(i, 1)
n = n + 1
End If
End If
i = i + 1
Loop
If Flag <> 0 Then
F1.Hide
MsgBox "the index are not unique!"
Application.DisplayAlerts = False
Rawdata.Parent.Windows(1).Visible = True
Rawdata.Delete
Application.DisplayAlerts = True
Newdata.Parent.Windows(1).Visible = True
TmpSheet.Parent.Windows(1).Visible = True
TmpSheet.Activate
End
Else
TmpSheet.Parent.Close False
End If
pbar.Value = 4
'*********************************************************************
On Error Resume Next
Rawdata.Name = "Upd" & Format(Date, "yymmdd")
On Error GoTo 0
Rawdata.Activate
If cells(1, 1) = "flag" Then
Columns(1).Clear
index_raw = index_raw + 1
Else
Columns(1).Insert '插入flag
index_raw = index_raw + 2
End If
Columns(1).Font.Color = vbBlue
Columns(index_raw - 1).Interior.ColorIndex = xlNone '避免红色干扰
Columns(1).Insert '插入索引
cells(1, 1) = "index"
cells(1, 2) = "flag"
raw_count = cells(1, 1).CurrentRegion.rows.count
For i = 1 To raw_count
cells(i, 1) = i - 1
Next i
pbar.Value = 5
'***************************找NewData工作表各列与RawData工作表的对应关系&copy
Rawdata.Activate
n = 1
Do Until Newdata.cells(1, n) = ""
n = n + 1
Loop
totalcol_new = n - 1
new_count = Newdata.UsedRange.rows.count
ReDim col(1 To totalcol_new)
i = 1: n = 1
Do Until Newdata.cells(1, i) = ""
j = 1: Flag_col = 0
Do Until Rawdata.cells(1, j) = "" Or Flag_col = 1
If LCase(CStr(Rawdata.cells(1, j))) = LCase(CStr(Newdata.cells(1, i))) Then
Flag_col = 1
col(n) = j
Newdata.cells(2, i).Resize(new_count - 1, 1).Copy
Rawdata.cells(raw_count + 1, j).Select
ActiveSheet.Paste
Selection.Interior.Color = vbRed
End If
j = j + 1
Loop
If Flag_col = 0 Then
If FrmUpdate.chk2.Value Then
Rawdata.cells(1, j) = Newdata.cells(1, i)
Rawdata.cells(1, j).Font.ColorIndex = 11
Rawdata.cells(1, j).Font.Bold = True
col(n) = j
Newdata.cells(2, i).Resize(new_count - 1, 1).Copy
Rawdata.cells(raw_count + 1, j).Select
ActiveSheet.Paste
Selection.Interior.Color = vbRed
Else
totalcol_new = totalcol_new - 1
n = n - 1
End If
End If
i = i + 1
n = n + 1
Loop
pbar.Value = 8
'更新数据************************************************************************>>>>>>>>>
DoEvents

cells.Select
Selection.Sort key1:=cells(2, index_raw), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
pbar.Value = 9
total_total = cells(1, 1).CurrentRegion.rows.count
neww = 0: same = 0: updated = 0: keep = 0
i = 2: DoEvents
Do Until cells(i, index_raw) = ""
pbar.Value = 9 + 62 * i / total_total
If cells(i, index_raw).Interior.Color = vbRed Then
If FrmUpdate.chk1.Value Then
cells(i, 1) = raw_count + 1 '添加到原始表格末尾
raw_count = raw_count + 1
cells(i, 2) = "New"
neww = neww + 1
cells(i, 2).Font.Color = vbRed
rows(i).Interior.ColorIndex = xlNone

End If
i = i + 1
Else
If LCase(CStr(cells(i, index_raw))) = LCase(CStr(cells(i + 1, index_raw))) Then
rows(i).Interior.ColorIndex = xlNone
rows(i).ClearComments
changed = 0
For j = 1 To totalcol_new
If LCase(cells(i, col(j))) <> LCase(cells(i + 1, col(j))) Then
cells(i, col(j)).Interior.ColorIndex = 36
changed = changed + 1
If cells(i, col(j)) <> "" Then
cells(i, col(j)).AddComment
cells(i, col(j)).Comment.Visible = False
cells(i, col(j)).Comment.Text Text:=CStr(cells(i, col(j)))
End If
If Not (cells(i + 1, col(j)) = "" And FrmUpdate.chk3.Value) Then
cells(i, col(j)) = cells(i + 1, col(j))
cells(i, col(j)).Interior.Color = vbGreen
changed = 10001
Else
cells(i, col(j)).ClearComments
End If
End If
Next j
If changed > 10000 Then
cells(i, 2) = "Updated"
updated = updated + 1
ElseIf changed > 0 Then
cells(i, 2) = "Keep"
keep = keep + 1
Else
cells(i, 2) = "Same"
same = same + 1
End If
i = i + 2
Else
i = i + 1
End If
End If
Loop
DoEvents
cells.Select
Selection.Sort key1:=cells(2, 1), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
pbar.Value = 73
total = cells(2, 2).CurrentRegion.rows.count
stringrow = (raw_count + 1) & ":" & total
If raw_count < total Then
rows(stringrow).Delete
ElseIf raw_count = total - 1 Then
rows(total).Delete
End If
Columns(1).Delete
cells(2, 2).Select
total = cells(2, 2).CurrentRegion.rows.count + 1 ' real total
cells(total, 1).Resize(65536 - total, 255).Delete Shift:=xlUp
pbar.Value = 74

pbar.Value = 75

Newdata.Parent.Windows(1).Visible = True
Rawdata.Parent.Windows(1).Visible = True
Rawdata.Activate
F1.Hide
x = MsgBox("Updated " & updated & "rows, " & neww & " new rows ", , "Result statistic")
End
End Sub
扫码关注5G通信官方公众号,免费领取以下5G精品资料
  • 1、回复“iot6”免费领取《【8月30号登载】物联网创新技术与产业应用蓝皮书——物联网感知技术及系统应用
  • 2、回复“6G31”免费领取《基于云网融合的6G关键技术白皮书
  • 3、回复“IM6G”免费领取《6G典型场景和关键能力白皮书
  • 4、回复“SPN2”免费领取《中国移动SPN2.0技术白皮书
  • 5、回复“LTKJ7”免费领取《 联通科技周17本白皮书合集
  • 6、回复“5g-a”免费领取《中国联通5G-A 通感算融合技术白皮书
  • 7、回复“URLLC”免费领取《中国联通5G URLLC 技术白皮书
  • 8、回复“LDSL”免费领取《中国移动算力网络技术白皮书
  • 对本帖内容的看法? 我要点评

     
    [充值威望,立即自动到帐] [VIP贵宾权限+威望套餐] 另有大量优惠赠送活动,请光临充值中心
    充值拥有大量的威望和最高的下载权限,下载站内资料无忧
    zhangqing822
    论坛副管
    鎵嬫満鍙风爜宸查獙璇


     发短消息    关注Ta 

    C友·铁杆勋章   C友·进步勋章   管理·优秀勋章   公益·慈善勋章   管理·贡献勋章   专家·初级勋章   “灌水之王”   纪念勋章·七周年   管理·标兵勋章   C友·幸运勋章   C友·登录达人   纪念勋章·五周年   财富勋章·富可敌国   纪念勋章·六周年   活动·摄影达人   纪念勋章·八周年   纪念勋章·九周年   纪念勋章·十周年   纪念勋章·十二周年   C友·技术大神  
    积分 125149
    帖子 19187
    威望 5177881 个
    礼品券 2787 个
    专家指数 3883
    注册 2008-6-17
    专业方向  通信工程
    回答问题数 0
    回答被采纳数 0
    回答采纳率 0%
     
    发表于 2013-01-10 23:07:25  QQ
    技术问题,回答得专家指数,快速升级
    表示真的看不懂的

    对本帖内容的看法? 我要点评





    如果有什么问题可以联系我(微信号zhangqing822),微信公众号(奔跑的C友网优学习交流号),里面发布的主要针对通信新人,欢迎大家的关注。
     
    [立即成为VIP会员,百万通信专业资料立即下载,支付宝、微信付款,简单、快速!]

    快速回复主题    
    标题
    内容
     上传资料请点左侧【添加附件】

    当前时区 GMT+8, 现在时间是 2024-03-29 13:43:52
    渝ICP备11001752号  Copyright @ 2006-2016 mscbsc.com  本站统一服务邮箱:mscbsc@163.com

    Processed in 0.342167 second(s), 16 queries , Gzip enabled
    TOP
    清除 Cookies - 联系我们 - 移动通信网 - 移动通信论坛 - 通信招聘网 - Archiver