【资料名称】: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工作表的对应关系©
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”免费领取《中国移动算力网络技术白皮书》
|