請問要如何使用EXCEL VBA 自動把特定範圍的值找到再貼到另一個工作表??

turion111
個人積分：102分
文章編號：59733475

102分

樓主

2016-04-04 14:01

因為是上下班時間表所以每個月的長度會不一樣，因此每個月都要更改圖2的範圍
現在是想說用尋找每個人的姓名，然後在這個範圍選取如圖1
像找"魏梅猜"對應的所有資料，然後將這些資料(b95:d125)再做複製、貼上到sheet1的動作。
請問要如何使用EXCEL VBA "自動"將特定範圍的值找到然後貼到另一個工作表??
而不用每個月"手動"更改圖2紅線的值
請問要如何使用EXCEL VBA 自動把特定範圍的值找到再貼到另一個工作表??

2016-04-04 14:01 發佈

文章關鍵字 Excel VBA 工作表範圍

gary4024

gary4024
個人積分：1605分
文章編號：59734669

1605分

2樓

2016-04-04 17:14

1. 先把原表依姓名排序
2。再用另一張工作表以match 函數找出每個名字第一筆出現的列數

粘XX 就是 1到94列
魏XX 就 95到119
................

再把上述的這些起始列數及終止列數帶到你的VBA

	A	B	C
1	姓名	起始列	終止列
2	粘XX	=match(xxxx) =1	=b3-1=94
3	魏梅猜	=match(xxxxxx) =95	=b4-1=119
4	張三	= match(ZZZZ) =120

snare

snare
個人積分：3057分
文章編號：59738365

3057分

3樓

2016-04-05 0:58

'(a1:d1) 第一列，必需是標題列
表格有沒有排序都可使用

Sheets("sheet4").Select
Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:="魏◎◎"
Columns("a:d").Select
Selection.SpecialCells(xlCellTypeVisible).Copy Sheets("sheet1").Range("i4")
Sheets("sheet4").Range("a1").Select
Selection.AutoFilter

名字不多的話，直接用，多複製幾次可以了
名字很多的話，想辦法練習一下，把這個程式碼變成迴圈

turion111

turion111
個人積分：102分
文章編號：59739390

102分

樓主

2016-04-05 8:15

gary4024 wrote:
1. 先把原表依姓名排序 2。再用另一張工作表以match 函數找出每個名字第一筆出現的列數粘XX 就是 1到94列魏XX 就 95到119................再把上述的這些起始列數及終止列數帶到你的VBA ABC1姓名起始列終止列2粘XX=match(xxxx) =1=b3-1=943魏梅猜=match(xxxxxx) =95=b4-1=1194張三= match(ZZZZ) =120
2016-04-05 00:58 by snare

謝謝gray4024的提示，我使用match在sheet5找出第一筆列數再照您的方式將儲存格帶入vba中就可以正確抓出資料了
但是最後一個員工找不到終止列，只好自已手動加一個"張三"幫忙找出終止列

snare wrote:
'(a1:d1) 第一列，必需是標題列表格有沒有排序都可使用 Sheets("sheet4").Select Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:="魏◎◎" Columns("a:d").Select Selection.SpecialCells(xlCellTypeVisible).Copy Sheets("sheet1").Range("i4") Sheets("sheet4").Range("a1").Select Selection.AutoFilter名字不多的話，直接用，多複製幾次可以了名字很多的話，想辦法練習一下，把這個程式碼變成迴圈

這個程式碼我也有試過再改動一下也可以正確找出資料。但是第一欄無法取消是有點不方便
也謝謝您提供的程式碼。

我現在程式碼是改成
Worksheets("sheet4").Select

Range("b" & Sheets(5).Range("b4").Value & ":d" & Sheets(5).Range("c4").Value & "").Select

Selection.Copy
Worksheets("sheet1").Select
Range("i4").Select
ActiveSheet.Paste

第二行就不用手動更新了!!

snare

snare
個人積分：3057分
文章編號：59744284

3057分

5樓

2016-04-05 18:36

turion111 wrote:
第一欄無法取消是有點不方便...(恕刪)

簡單一點的，在程式碼倒數第2行，多加一行
sheets("sheet1").Range("I4:L4").Delete Shift:=xlUp

至於sheet5 最後一筆資料
=counta(sheet4!a:a)

不過，即然可以多增加一個sheet5，上面又有姓名欄位
可試看看，改用迴圈，程式碼只要多 for .... next 這2行
目測您的程式大概有40多行，這樣可簡化到8行
而且，好處是不管姓名增加或減少，程式都不用再修改

紅字部份修改成變數就好，幫您標出來了
我的程式碼請往上看

如果是您自己寫的，如下
Worksheets("sheet4").Select
Range("b" & Sheets(5).Range("b4").Value & ":d" & Sheets(5).Range("c4").Value & "").Select
Selection.Copy
Worksheets("sheet1").Select
Range("i4").Select
ActiveSheet.Paste

turion111

turion111
個人積分：102分
文章編號：59744955

102分

樓主

2016-04-05 20:10

snare wrote:
可試看看，改用迴圈，程式碼只要多 for .... next 這2行

我有試著做迴圈也可以正確抓出資料
程式碼也精簡了不少!!
只是以後增加員工還是要來改正i值
但是已經非常方便了
謝謝!!

Dim i As Integer
For i = 2 To 8
Sheets("sheet4").Select
Range("b" & Sheets(5).Range("b" & i & "") & ":d" & Sheets(5).Range("c" & i & "") & "").Select
Selection.copy
Sheets("Sheet1").Select
Range("" & Sheets(5).Range("d" & i & "") & "").Select
ActiveSheet.Paste
Next i

snare

snare
個人積分：3057分
文章編號：59745077

3057分

7樓

2016-04-05 20:22

turion111 wrote:
只是以後增加員工還是要來改正i值...(恕刪)

i值，可用 sheets("sheet5").Range("A1").End(xlDown).Row 代替

turion111

turion111
個人積分：102分
文章編號：59748405

102分

樓主

2016-04-06 6:47

snare wrote:
i值，可用 sheets("sheet5").Range("A1").End(xlDown).Row 代替

非常感謝!!!
以後就只要按一鍵就可以完成薪資表了
不用像以前一樣複製再貼上重複的動作一直做

snare

snare
個人積分：3057分
文章編號：59758334

3057分

9樓

2016-04-06 22:32

turion111 wrote:
非常感謝!!!以後...(恕刪)

不必客氣，願意自己練習的，我都很樂意幫忙

雖然您的程式沒問題了，參考一下我寫的吧
程式碼稍微長了一點，但好處是 => 不必排序，不必新增其它工作表，不需其它函數
看看您能不能學到什麼

'將 sheet1( a~d欄 )，a欄所有重覆項目，不含a1~d1標題，自動分類複製到 sheet2
'要標題的話，把 offset(1,0). 刪掉就好

sub copydata()
Dim temparray() As Variant
Worksheets("Sheet2").Cells.Clear
Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ReDim temparray(Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible).Count - 1)

For Each namedata In Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
i = i + 1: If i > 1 Then temparray(i - 2) = namedata
Next
For Each namedata In temparray
j = j + 1
If namedata = "" Then Exit For

Sheets("sheet1").Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:=namedata
Sheets("sheet1").AutoFilter.Range.Offset(1,0).Resize(Sheets("sheet1").AutoFilter.Range.Rows.Count, 4).SpecialCells(xlCellTypeVisible).Copy Sheets("sheet2").Cells(2, ((j - 1) * 5) + 1)

Next
Sheets("sheet1").AutoFilterMode = False
end sub

基本上只要是資料都通用
但如果要分類日期(a欄)、時間(a欄)，這一行temparray(i - 2) = namedata 中的 namedata 要轉換格式)
例如：a2=四月六號，程式碼抓出來的是 2016-4-6 星期三，會無法分類

turion111

turion111
個人積分：102分
文章編號：59761756

102分

樓主

2016-04-07 9:49

snare wrote:
參考一下我寫的吧

我參考您寫的程式碼後再改一下
抓出來的資料如上圖
現在想在d欄後每四欄自動計算工作時間到分鐘
我的程式碼如下
請幫我看看要怎麼改正??

Sub copydata()
Dim temparray() As Variant
Worksheets("Sheet2").Cells.Clear
Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ReDim temparray(Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).Count)
For Each namedata In Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
i = i + 1: If i > 1 Then temparray(i - 2) = namedata
Next
For Each namedata In temparray
j = j + 1
Sheets("sheet1").Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:=namedata
Sheets("sheet1").AutoFilter.Range.Offset(1, 1).Resize(Sheets("sheet1").AutoFilter.Range.Rows.Count, 4).Copy Sheets("Sheet2").Cells(4, ((j - 1) * 4) + 1)
Next
Sheets("sheet1").AutoFilterMode = False

For x = 4 To 60 Step 4 ~~60這個值是亂取的
For a = 4 To 34

Sheets(2).Cells(a, x) = Sheets(2).Cells(a - 1, x) - Sheets(2).Cells(a - 2, x)～～這行使用迴圈算出來的全是0

Sheets(2).Range("d" & a & "") = Sheets(2).Range("c" & a & "") - Sheets(2).Range("b" & a & "")~~~這行只計算出d欄＝c-b欄但是不知道怎麼用時間表示

Next a
Next x

End Sub