Board logo

標題: [發問] 對應欄位問題 [打印本頁]
作者: starbox520    時間: 2016-12-9 16:00     標題: 對應欄位問題

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

可以設置一開啟EXCEL就自動跑好嗎?
[attach]26060[/attach]
[attach]26061[/attach]
作者: starbox520    時間: 2016-12-9 17:58

  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    時間: 2016-12-10 10:57

回復 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)

  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

  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

  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    時間: 2016-12-10 11:39

http://blog.xuite.net/hcm19522/twblog/474457571
作者: starbox520    時間: 2016-12-10 12:38

回復 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    時間: 2016-12-12 12:13

本帖最後由 starbox520 於 2016-12-12 12:14 編輯

回復 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
     會出現型態不符
     排版也變了，詳請附檔
     該怎麼修改呢

   [attach]26075[/attach]
作者: c_c_lai    時間: 2016-12-12 13:51

回復 6# starbox520
[attach]26076[/attach]
作者: c_c_lai    時間: 2016-12-12 14:05

本帖最後由 c_c_lai 於 2016-12-12 14:08 編輯

回復 6# starbox520
[attach]26078[/attach]
這是我把 POA、以及 POB 的內容值修改了。
作者: c_c_lai    時間: 2016-12-12 17:35

本帖最後由 c_c_lai 於 2016-12-12 17:36 編輯

回復 6# starbox520
依照妳 #6 所附 scanttt.xlsx  原本資料 (未加異動)，
執行之修改版本。
因為每一陣列變數有 "最長不能超過 255" 的限制，
所以程式裡加了判斷，超出部分予以截掉不處裡。
[attach]26080[/attach]
作者: starbox520    時間: 2016-12-12 17:57

回復 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
複製代碼
作者: c_c_lai    時間: 2016-12-12 19:14

本帖最後由 c_c_lai 於 2016-12-12 19:17 編輯

回復 10# starbox520
沒錯！
使用第二種方法 (ReDim Preserve)，雖受限於 Application.Transpose() 255 的限制，
但它能得以動態的增加陣列，是它的優點。但是由於妳現有的案例卻不太適合，是故改採
一次直接宣告陣列大小的第一種方法 (ReDim ar())，而將陣列直接移轉 (Assign) 到工作表單內。
不致受限於 Transpose() 長度的限制。
  1. Sub Ex()
  2.     Dim ln As Variant, ar As Variant
  3.     Dim cts As Integer, ct2 As Integer
  4.    
  5.     With Sheets("Data")
  6.         ln = .[A1].CurrentRegion.Value      '  Ln :  : Variant/Variant(1 to 177, 1 to 35)
  7.         '  UBound(Ln, 1) = 177 : Long   /   UBound(Ln, 2) : 35 : Long
  8.         ReDim ar(1 To UBound(ln, 2) + 1, 1 To 2)

  10.         For cts = 1 To UBound(ln, 2) - 5
  11.             ar(cts, 1) = ln(1, cts + 1)  
  12.             ar(cts, 2) = ""
  13.             For ct2 = 3 To UBound(ln, 1)
  14.                  If ln(ct2, cts + 1) <> 0 Then
  15.                     ar(cts, 2) = IIf(ar(cts, 2) = "", ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1), _
  16.                                         ar(cts, 2) & "," & ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1))
  17.                 End If
  18.             Next ct2
  19.         Next cts
  20.     End With
  21.         
  22.     With Sheets("TEST")
  23.         .[H:I] = ""
  24.         .[H2].Resize(UBound(ar, 1), UBound(ar, 2)) = ar
  25.     End With
  26. End Sub
複製代碼
[attach]26082[/attach]
作者: c_c_lai    時間: 2016-12-12 20:19

P0A 的組合：
[attach]26084[/attach]
作者: c_c_lai    時間: 2016-12-13 06:37

本帖最後由 c_c_lai 於 2016-12-13 09:15 編輯

回復 10# starbox520
這是之前執行第二種方式 (Ex1()) 所產生錯誤之原因：
[attach]26087[/attach]
作者: starbox520    時間: 2016-12-14 11:38

回復 13# c_c_lai


    原來如此

   謝謝C大解說!!
作者: starbox520    時間: 2016-12-21 17:17

回復 13# c_c_lai

    [attach]26131[/attach][attach]26132[/attach]
     
    如果像這樣只要取S#XX 或M#XX  前面CF00不要取到，然後第174.175.254.255 不要讀到這4列的資訊(反黃部分)
    另外C大之前的寫法連同把B欄的資訊寫到G欄，這部分去除掉
     只要H欄的呈現資訊， 這樣要怎麼修改呢~

     [attach]26133[/attach]
作者: c_c_lai    時間: 2016-12-21 19:31

回復 15# starbox520
第174.175.254.255 不要讀到這4列的資訊(反黃部分) ?
不太明瞭，請白話一點，
是忽略不去計列處理，還是？
作者: starbox520    時間: 2016-12-21 20:55

回復 16# c_c_lai


    對就是忽略~
作者: c_c_lai    時間: 2016-12-22 06:07

回復 17# starbox520
但是妳的 SQ0001 反黃的部分是 127、255、127、116，
那 又是怎麼回事？
116、127 也算數嗎？
作者: c_c_lai    時間: 2016-12-22 07:10

回復 15# starbox520
不等妳的確認回復了，
我準備要出門去林口長庚回診了。
[attach]26160[/attach]
作者: starbox520    時間: 2016-12-22 09:01

回復 18# c_c_lai


    Sorry現在才看到Q0Q
    可是我看開起的附檔
     只有這兩個有反黃QQ
     [attach]26164[/attach][attach]26163[/attach]
     CF00M#SC    CF00M#TER    CF00S#S   CF00S#TE   
     這4列略過
     為什麼要去醫院阿
     看眼睛嗎 Q0Q
     保重身體耶~C大大!!!
作者: c_c_lai    時間: 2016-12-23 06:00

本帖最後由 c_c_lai 於 2016-12-23 07:54 編輯

回復 20# starbox520
#19  執行結果如何？
是否可以敲下課鈴了？
[attach]26169[/attach]
作者: starbox520    時間: 2016-12-23 08:30

回復 21# c_c_lai


    我只是把A欄數據改另一個名稱(改成CF62300)
    數據量一樣
    就會出現引數不對的狀況耶~
   
    [attach]26171[/attach]
    [attach]26172[/attach]
作者: starbox520    時間: 2016-12-23 08:35

回復 21# c_c_lai


    另外TR排機
    有些問題想再問你哈哈...
    我自己加的東西好像有Bug...
     您幫忙我的有些可能要在加個判斷QOQ
     要回在另一個版塊嗎
     這次我知道怎麼描述了
     以防您眼睛吃力
     我得想盡辦法讓你一目了然XD
作者: c_c_lai    時間: 2016-12-23 08:51

回復 22# starbox520
妳把          '  ln(ct2, 1) = IIf(ins > 0, Mid(ln(ct2, 1), ins - 1), ln(ct2, 1))   '  只截取 S#XX 或 M#XX  前面 CF00 去除。
改成        If ins > 0 Then ln(ct2, 1) = Mid(ln(ct2, 1), ins - 1)
作者: c_c_lai    時間: 2016-12-23 09:02

回復 22# starbox520
If ins > 1 Then ln(ct2, 1) = Mid(ln(ct2, 1), ins - 1)
比較保險 (CF00M001 或者是 #CF00M02 之假設)。
作者: starbox520    時間: 2016-12-23 09:22

回復 25# c_c_lai


    可以了!!
    果然是這行搞得鬼~
作者: c_c_lai    時間: 2016-12-23 10:41

回復  c_c_lai


    另外TR排機
    有些問題想再問你哈哈...
    我自己加的東西好像有Bug...
    ...
starbox520 發表於 2016-12-23 08:35

是甚麼狀況？
作者: 准提部林    時間: 2016-12-23 11:20

If ln(ct2, cts + 1) <> 0 And (ln(ct2, cts + 1) <> 174 And ln(ct2, cts + 1) <> 175 And ln(ct2, cts + 1) <> 254 And ln(ct2, cts + 1) <> 255) Then
174-175-254-255 是"列號", ln(ct2, cts + 1) 是"數字", 怎對得上???


另, 程式還須考慮"可讀性", 會多次引用的, 儘量以變數代替, 免看得眼花,
IIF 這方式也可以簡化, 看起來也較易了解:
ar(cts, 1) = IIf(ar(cts, 1) = "", ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1), _
                                        ar(cts, 1) & "," & ln(ct2, 1) & IIf(ln(ct2, cts + 1) > 0, "+", "") & ln(ct2, cts + 1))
t$ = Format(ln(ct2, cts + 1), "+0;-0")
ar(cts, 1) = Replace(Trim(ar(cts, 1) & " " & ln(ct2, 1) & t), " ", ",")
作者: starbox520    時間: 2016-12-23 13:19

回復 28# 准提部林


    謝謝准大的提示
    我在去測試看看!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)