資料複製的三種範例

楼主
allall

資料複製的三種範例

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '讓電腦暫停一些時間千分之一秒
'
' 將資料從表一複製到表二
'
Private Sub CommandButton1_Click()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim nRow1 As Long '紀錄現在處理至第幾列
Dim nRow2 As Long
Dim blnContinue As Boolean
Set sht1 = Sheets("表一") '讓sht1 = 表一.. 萬一以後改名字, 在這裡修改即可
Set sht2 = Sheets("表二")
nRow1 = 1
nRow2 = 1
blnContinue = True
'以迴圈處理不定長度的資料
Do While blnContinue
'複製資料的動作
sht2.Cells(nRow2, 1).Value = sht1.Cells(nRow1, 1).Value
sht2.Cells(nRow2, 2).Value = sht1.Cells(nRow1, 2).Value
sht2.Cells(nRow2, 3).Value = sht1.Cells(nRow1, 3).Value
'若已經複製完成, 需要將處理列的標記+1
nRow1 = nRow1 + 1
nRow2 = nRow2 + 1
'設定離開條件... 此例是表一由上到下, 連續處理至空白時要停止動作, 離開迴圈
If sht1.Cells(nRow1, 1).Value = "" Then
blnContinue = False
End If
Loop
End Sub
Private Sub CommandButton2_Click()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim nRow1 As Long '紀錄現在處理至第幾列
Dim nRow2 As Long
Dim blnContinue As Boolean
Set sht1 = Sheets("表一") '讓sht1 = 表一.. 萬一以後改名字, 在這裡修改即可
Set sht2 = Sheets("表二")
nRow1 = 1
nRow2 = 1
blnContinue = True
'以迴圈處理不定長度的資料
Do While blnContinue
'複製資料的動作
sht2.Cells(nRow2, 1).Value = sht1.Cells(nRow1, 1).Value
sht2.Cells(nRow2, 2).Value = sht1.Cells(nRow1, 2).Value
sht2.Cells(nRow2, 3).Value = sht1.Cells(nRow1, 3).Value
'若已經複製完成, 需要將處理列的標記+1
nRow1 = nRow1 + 1
nRow2 = nRow2 + 1
sht1.Cells(6, 9).Value = nRow1 '可以顯示現在複製到第幾行
Call Sleep(20) '只是為了讓處理速度變慢
'設定離開條件... 此例是表一由上到下, 連續處理至空白時要停止動作, 離開迴圈
If sht1.Cells(nRow1, 1).Value = "" Then
blnContinue = False
End If
Loop
Call MsgBox("完成") '顯示已經做完了～～
End Sub
' 要先進行設定：
'
' 選單/工具/設定引用項目(R)... -> [Microsoft Scripting Runtime] 打勾勾
'
Private Sub CommandButton3_Click()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim shtTbl As Worksheet
Dim nRow1 As Long '紀錄現在處理至第幾列
Dim nRow2 As Long
Dim blnContinue As Boolean
'--------------
Dim dicTbl As Dictionary '儲存對照表的位置
Set dicTbl = New Dictionary '建立一個 Dictionary 物件
Set shtTbl = Sheets("對照表")
nRow1 = 2
blnContinue = True
'利用小迴圈將資料存到Dictionary
Do While blnContinue
If Not dicTbl.Exists(shtTbl.Cells(nRow1, 1).Value) Then '若不存在於 Dictionary 才加入
Call dicTbl.Add(shtTbl.Cells(nRow1, 1).Value, nRow1) '<-加入 Dictionary 中
End If
nRow1 = nRow1 + 1
If shtTbl.Cells(nRow1, 1).Value = "" Then
blnContinue = False
End If
Loop
'---------------
Set sht1 = Sheets("表一") '讓sht1 = 表一.. 萬一以後改名字, 在這裡修改即可
Set sht2 = Sheets("表二")
nRow1 = 1
nRow2 = 1
blnContinue = True
'以迴圈處理不定長度的資料
Do While blnContinue
'複製資料的動作
sht2.Cells(nRow2, 1).Value = sht1.Cells(nRow1, 1).Value
sht2.Cells(nRow2, 2).Value = sht1.Cells(nRow1, 2).Value
sht2.Cells(nRow2, 3).Value = sht1.Cells(nRow1, 3).Value
If dicTbl.Exists(sht1.Cells(nRow1, 1).Value) Then
sht2.Cells(nRow2, 4).Value = shtTbl.Cells(dicTbl(sht1.Cells(nRow1, 1).Value), 2).Value
End If
'若已經複製完成, 需要將處理列的標記+1
nRow1 = nRow1 + 1
nRow2 = nRow2 + 1
sht1.Cells(10, 9).Value = nRow1 '可以顯示現在複製到第幾行
'Call Sleep(50) '只是為了讓處理速度變慢
'設定離開條件... 此例是表一由上到下, 連續處理至空白時要停止動作, 離開迴圈
If sht1.Cells(nRow1, 1).Value = "" Then
blnContinue = False
End If
Loop
Call MsgBox("完成") '顯示已經做完了～～
End Sub

詳細請下載附件檔案page1.jpg

sample.rar

2楼
亡者天下

怎么用繁体字啊？