帖子: 45
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: ?
軟體版本: ?
閱讀權限: 20
註冊時間: 2016-3-17
最後登錄: 2019-11-19

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2016-9-6 22:12 | 只看該作者

[發問] 關於使用錄製巨集編修程式碼--->"無資料則跳過"

將"職等"欄位使用篩選，將資料貼上值帶到右側

問題1
因為五職等沒有人，如何改成"無資料則跳過"

問題2
由於是使用錄製巨集的模式，程式碼一長串，如何用簡單幾個程式碼達到一模一樣的效果

無資料則跳過.zip (14.34 KB)

樓主熱帖

chiang0320

中學生 Rank: 2

帖子: 45
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: ?
軟體版本: ?
閱讀權限: 20
註冊時間: 2016-3-17
最後登錄: 2019-11-19

7^#

發表於 2016-10-3 21:46 | 只看該作者

回復 6# GBKEE

謝謝! GBKEE

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2016-10-2 09:42 | 只看該作者

本帖最後由 GBKEE 於 2016-10-2 09:44 編輯

回復 5# chiang0320
你所錄製巨集程式碼,濃縮後的程式碼

Option Explicit
Sub Ex()
Dim AR(), i As Integer
AR = Array("一", "二", "三", "四", "五")
Range("J2").CurrentRegion.Offset(1) = "" '清除舊有資料
For i = 0 To UBound(AR)
ActiveSheet.Range("A1").AutoFilter Field:=2, Criteria1:=AR(i) '範圍自動篩選指定第2個欄位,條件=AR(i)
If Range("B2").End(xlDown).Row <> Rows.Count Then '有資料
Range("B3", Range("B3").End(xlDown)).Copy Range("J2").Offset(1, i)
End If
Next
ActiveSheet.Range("A1").AutoFilter '取消自動篩選(沒有指定條件)
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

chiang0320

中學生 Rank: 2

帖子: 45
主題: 15
精華: 0
積分: 92
點名: 0
作業系統: ?
軟體版本: ?
閱讀權限: 20
註冊時間: 2016-3-17
最後登錄: 2019-11-19

5^#

發表於 2016-9-21 23:30 | 只看該作者

如果是以檔案裡面錄製的程式碼去改，要怎麼呈現呢?

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

4^#

發表於 2016-9-7 13:16 | 只看該作者

Sub TEST()
Dim xR As Range, xF As Range
For Each xR In Range([B3], [B65536].End(xlUp))
　　Set xF = [J2:N2].Find(xR(1, 2), Lookat:=xlPart)
　　If Not xF Is Nothing Then xF(60000, 1).End(xlUp)(2, 1) = xR
Next
End Sub

TOP

ikboy

中學生 Rank: 2

帖子: 262
主題: 8
精華: 0
積分: 280
點名: 17
作業系統: xp
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2015-8-11
最後登錄: 2024-11-19

2016猴年全勤獎章

3^#

發表於 2016-9-7 11:49 | 只看該作者

回復 1# chiang0320

試下:

Sub ZZ()
Dim ar, rng As Range, d As Object, k, t
Set d = CreateObject("scripting.dictionary")
Set rng = Range([j2], [j2].End(2))
ar = [b2].CurrentRegion
t = [c2]
For i = 2 To UBound(ar)
d(ar(i, 2) & t) = d(ar(i, 2) & t) & "|" & ar(i, 1)
Next
k = d.keys
For i = 0 To UBound(k)
j = Application.Match(k(i), rng, 0)
t = Split(Mid(d(k(i)), 2), "|")
rng.Cells(1, j).Offset(1, 0).Resize(UBound(t) + 1, 1) = Application.Transpose(t)
Next
End Sub

複製代碼

TOP

rouber590324

高中生 Rank: 3 Rank: 3

帖子: 561
主題: 160
精華: 0
積分: 725
點名: 0
作業系統: WINDOWS
軟體版本: xp
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2014-9-10
最後登錄: 2024-8-7

論壇榮譽勳章論壇贊助勳章熱烈參與勳章

2^#

發表於 2016-9-7 10:48 | 只看該作者

如下試試

Sub 轉置()
Sheet1.[J3:N65536].ClearContents
X = Sheet1.[B65536].End(xlUp).Row
Y1 = Sheet1.[J65536].End(xlUp).Row
Y2 = Sheet1.[K65536].End(xlUp).Row
Y3 = Sheet1.[L65536].End(xlUp).Row
Y4 = Sheet1.[M65536].End(xlUp).Row
Y5 = Sheet1.[N65536].End(xlUp).Row
For M = 3 To X
If Sheet1.Cells(M, 3) = "一" Then
Sheet1.Cells(Y1 + 1, 10) = Sheet1.Cells(M, 2)
Y1 = Y1 + 1
End If
If Sheet1.Cells(M, 3) = "二" Then
Sheet1.Cells(Y2 + 1, 11) = Sheet1.Cells(M, 2)
Y2 = Y2 + 1
End If
If Sheet1.Cells(M, 3) = "三" Then
Sheet1.Cells(Y3 + 1, 12) = Sheet1.Cells(M, 2)
Y3 = Y3 + 1
End If
If Sheet1.Cells(M, 3) = "四" Then
Sheet1.Cells(Y4 + 1, 13) = Sheet1.Cells(M, 2)
Y4 = Y4 + 1
End If
If Sheet1.Cells(M, 3) = "五" Then
Sheet1.Cells(Y5 + 1, 14) = Sheet1.Cells(M, 2)
Y5 = Y5 + 1
End If
Next
End Sub

羅

TOP