[發問] 對應欄位問題

starbox520

要怎麼將如圖的對應欄位，變成像工作表2都寫在同一個儲存格裡 (0以外的才要)

可以設置一開啟EXCEL就自動跑好嗎?

下載 (19.16 KB)

2016-12-9 15:58

test300.rar (7.49 KB)

下載次數: 9

2016-12-9 15:59

starbox520

1. Private Sub Workbook_Open()
   
2.     Dim arA, arB, x%, y%, s$
   
3.     Sheets("工作表2").Activate
   
4.     [a1].CurrentRegion.Offset(1).ClearContents
   
5.     arA = Sheets("工作表1").UsedRange
   
6.     ReDim arB(1 To UBound(arA, 2) - 1, 1 To 2)
   
7.     For y = 2 To UBound(arA, 2)
   
8.         arB(y - 1, 1) = arA(1, y)
   
9.         For x = 3 To UBound(arA)
   
10.             If arA(x, y) <> 0 Then
    
11.                 s = IIf(arA(x, y) > 0, arA(x, 1) & "+" & arA(x, y), arA(x, 1) & arA(x, y))
    
12.                 arB(y - 1, 2) = IIf(arB(y - 1, 2) = "", s, arB(y - 1, 2) & " , " & s)
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     [a2].Resize(UBound(arB), 2) = arB
    
17. End Sub

複製代碼

c_c_lai

回復 2# starbox520
妳的功力有增強了，加油！
以下兩個模組在使用陣列時，應用上有些許變化，
提供妳參考：

1. Sub Ex()
   
2.     Dim ln As Variant, ar As Variant
   
3.     Dim cts As Integer, ct2 As Integer
   
4.    
   
5.     With 工作表1
   
6.         ln = .[A1].CurrentRegion.Value
   
7.         ReDim ar(1 To UBound(ln, 2) - 1, 1 To 2)
   
8. 
   
9.         For cts = 1 To UBound(ln, 2) - 1
   
10.             ar(cts, 1) = ln(1, cts + 1)
    
11.             ar(cts, 2) = ""
    
12.             For ct2 = 3 To UBound(ln, 1)
    
13.                 If ln(ct2, cts + 1) <> 0 Then
    
14.                     ar(cts, 2) = IIf(ar(cts, 2) = "", ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1), _
    
15.                              ar(cts, 2) & "," & ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1))
    
16.                 End If
    
17.             Next ct2
    
18.         Next cts
    
19. 
    
20.         With 工作表2
    
21.             .UsedRange.ClearContents
    
22.             .[A1].Resize(UBound(ar, 1), UBound(ar, 2)) = ar
    
23.         End With
    
24.     End With
    
25. End Sub

複製代碼

1. Sub Ex1()      '  ReDim Preserve 的應用；變更最後維度的大小時，用來保留現有陣列資料。
   
2.     Dim ln As Variant, ar As Variant
   
3.     Dim cts As Integer, ct2 As Integer
   
4.    
   
5.     With 工作表1
   
6.         ln = .[A1].CurrentRegion.Value
   
7.         '  UBound(Ln, 1) = 25 : Long   /   UBound(Ln, 2) : 8 : Long
   
8. 
   
9.         For cts = 1 To UBound(ln, 2) - 1
   
10.             If IsEmpty(ar) Then ReDim ar(1 To 2, 1 To 1) Else ReDim Preserve ar(1 To 2, 1 To UBound(ar, 2) + 1)
    
11.             ar(1, cts) = ln(1, cts + 1)
    
12.             ar(2, cts) = ""
    
13.             For ct2 = 3 To UBound(ln, 1)
    
14.                 If ln(ct2, cts + 1) <> 0 Then
    
15.                     ar(2, cts) = IIf(ar(2, cts) = "", ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1), _
    
16.                               ar(2, cts) & "," & ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1))
    
17.                 End If
    
18.             Next ct2
    
19.         Next cts
    
20.         
    
21.         With 工作表2
    
22.             .UsedRange.ClearContents
    
23.             .[A1].Resize(UBound(ar, 2), UBound(ar, 1)) = Application.Transpose(ar)
    
24.         End With
    
25.     End With
    
26. End Sub

複製代碼

hcm19522

http://blog.xuite.net/hcm19522/twblog/474457571

starbox520

回復 3# c_c_lai
回復 3# hcm19522

    好唷!!!
    正在努力學習一些好懂的><

    下變得版h大用巨集
    我看不太懂XD  這是公式的意思嗎
    沒試過

1. K2:O8{=IFERROR(IF(COLUMN(A1)=1,"",",")&INDEX($A:$A,SMALL(IF(($B$3:$H$25<>0)*($B$1:$H$1=$J2),ROW(B$3:H$25)),COLUMN(A1)))&TEXT(N(INDIRECT(TEXT(SMALL(IF(($B$3:$H$25<>0)*($B$1:$H$1=$J2),ROW(B$3:H$25)*100+COLUMN($B3:$H25)),COLUMN(A1)),"!R0C00"),)),"!+0;!-0")&L2,"")

複製代碼

starbox520

回復 3# c_c_lai


    C大第二種是可以選擇範圍的意思吼
    會變成這樣?
   '  UBound(Ln, 1) = 177 : Long   /   UBound(Ln, 2) : 31 : Long
      31是我只要判斷到 "AE"欄而已
     工作表 "TEST是寫入"的地方，這邊我要多判斷 A欄的  M#SCC   跟 S#SCC  不要做處理(顯示)
     我試過在IF加入 If arA(x, y) <> 0 And arA <> "M#SCC" And arA <> "S#SCC" Then
     會出現型態不符
     排版也變了，詳請附檔
     該怎麼修改呢

    scanttt.rar (20.36 KB)

下載次數: 5

2016-12-12 12:14

c_c_lai

回復 6# starbox520

下載 (106.22 KB)

2016-12-12 13:51

c_c_lai

回復 6# starbox520
scanttt.rar (27.91 KB)

下載次數: 2

2016-12-12 14:04

這是我把 POA、以及 POB 的內容值修改了。

c_c_lai

回復 6# starbox520
依照妳 #6 所附 scanttt.xlsx  原本資料 (未加異動)，
執行之修改版本。
因為每一陣列變數有 "最長不能超過 255" 的限制，
所以程式裡加了判斷，超出部分予以截掉不處裡。
scanttt.rar (30.89 KB)

下載次數: 7

2016-12-12 17:35

starbox520

回復 9# c_c_lai


    C大我以我會的寫法練習一次
    這方法好像不會超過
    但問題點是把AE欄以後的也判斷進去了
    怕未來資料量越來越多的話，會卡在這個問題XD
    所以先研究起來放哈哈

1. Private Sub Workbook_Open()
   
2.     Dim vData As Variant, nRow As Integer, nCol As Integer
   
3.     Dim vFill As Variant
   
4.    
   
5.     vData = Sheets("Data").UsedRange
   
6.     ReDim vFill(2 To UBound(vData, 2), 1 To 8)
   
7.     For nCol = 2 To UBound(vData, 2)
   
8.         vFill(nCol, 2) = vData(1, nCol)
   
9.         For nRow = 3 To UBound(vData)
   
10.             If vData(nRow, nCol) <> 0 And vData(nRow, 1) <> "M#SCC" And vData(nRow, 1) <> "S#SCC" Then
    
11.                 If vFill(nCol, 8) <> "" Then vFill(nCol, 8) = vFill(nCol, 8) & ","
    
12.                 vFill(nCol, 8) = vFill(nCol, 8) & vData(nRow, 1) & IIf(vData(nRow, nCol) > 0, "+", "") & vData(nRow, nCol)
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     With Sheets("TEST")
    
17.         .[A1].CurrentRegion.Offset(1).ClearContents
    
18.         .[A2].Resize(UBound(vFill) - 1, 8) = vFill
    
19.     End With
    
20. End Sub

複製代碼