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

chiang0320

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

下載 (52.39 KB)

2016-9-6 22:10

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

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

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

下載次數: 18

2016-9-6 22:11

rouber590324

如下試試

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

ikboy

回復 1# chiang0320


   
試下:

1. Sub ZZ()
   
2. Dim ar, rng As Range, d As Object, k, t
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set rng = Range([j2], [j2].End(2))
   
5. ar = [b2].CurrentRegion
   
6. t = [c2]
   
7. For i = 2 To UBound(ar)
   
8.     d(ar(i, 2) & t) = d(ar(i, 2) & t) & "|" & ar(i, 1)
   
9. Next
   
10. k = d.keys
    
11. For i = 0 To UBound(k)
    
12.     j = Application.Match(k(i), rng, 0)
    
13.     t = Split(Mid(d(k(i)), 2), "|")
    
14.     rng.Cells(1, j).Offset(1, 0).Resize(UBound(t) + 1, 1) = Application.Transpose(t)
    
15. Next
    
16. End Sub

複製代碼

准提部林

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

chiang0320

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

GBKEE

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

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

複製代碼

chiang0320

回復 6# GBKEE


    謝謝! GBKEE