返回列表 上一主題 發帖

請問不知可否寫程式帶出可用機台

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
1# 跳轉到 »
發表於 2016-4-16 04:53 | 顯示全部帖子
回復 1# Qektyyrwp

  1. Sub nn()
  2. Dim lRow&
  3. Dim vD, vTemp

  5. Set vD = CreateObject("Scripting.Dictionary")

  7. lRow = 2
  8. While Cells(lRow, 1) <> ""
  9.    If Left(Cells(lRow, 3), 4) <> "nona" Then ' 可用才加入
  10.      If vD.exists(CStr(Cells(lRow, 1))) Then
  11.        If vD(CStr(Cells(lRow, 1))) = "" Then
  12.          vD(CStr(Cells(lRow, 1))) = Cells(lRow, 2)
  13.        Else
  14.          vD(CStr(Cells(lRow, 1))) = vD(CStr(Cells(lRow, 1))) & "," & Cells(lRow, 2)
  15.        End If
  16.      Else
  17.        vD(CStr(Cells(lRow, 1))) = Cells(lRow, 2)
  18.      End If
  19.    Else
  20.      vD(CStr(Cells(lRow, 1))) = ""
  21.    End If
  22.    lRow = lRow + 1
  23. Wend

  25. [A16:B50].Clear
  26. lRow = 16
  27. For Each vTemp In vD
  28.    Cells(lRow, 1) = vTemp
  29.    If vD(vTemp) <> "" Then
  30.      Cells(lRow, 2) = vD(vTemp)
  31.    Else
  32.      Cells(lRow, 2) = "無"
  33.    End If
  34.    lRow = lRow + 1
  35. Next
  36. End Sub
複製代碼
寫程式帶出可用機台-a.zip (13.92 KB)

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題