Excel VBA 請益 II

zz0660

下載 (117.69 KB)

2021-7-24 16:48

下載 (206.28 KB)

2021-7-24 16:48

AA表單C1為下拉式選單，裡面有三個圖示想做成按鈕，分別對應QQ表單的T1 & T2 & T3資料。
主要是今天想在QQ表單的T1資料，輸入數據，然後只要從AA表單按T1的按鈕，就能直接輸入數據，而不必跳到QQ表單內然後輸入資料。

在此提供檔案。
BTT.rar (26.55 KB)

下載次數: 7

2021-7-24 16:54

samwang

回復 1# zz0660

是這樣嗎?

Sub test_T1()
Dim Arr, T, T1, i&, j&
T = Sheets("AA").Range("c1")
Ar = Sheets("AA").Range("b3:i19")
With Sheets("QQ")
     Arr = .Range("a1:h" & .[b65536].End(3).Row) 'T1   T1,T2,T3請自行選擇更換
    'Arr = .Range("j1:q" & .[k65536].End(3).Row) 'T2
     'Arr = .Range("s1:z" & .[t65536].End(3).Row) 'T3
     For i = 1 To UBound(Arr) Step 19
         T1 = Arr(i, 2): If T1 = "" Then GoTo 99
         If T1 = T Then
             .Cells(i, 1).Offset(1).Resize(16, 8).Value = Ar
             Exit Sub
         End If
99:   Next
End With
End Sub

zz0660

回復 2# samwang

程式可以，但今天想把按鈕換成下拉式選單的方式呈現，如C1 & D1 個別為下拉式選單。

下載 (12.54 KB)

2021-7-28 09:52

請問該如何修改呢?，謝謝!

zz0660

回復 2# samwang

Sub test_T1()
Dim Arr, T,U ,T1, i&, j&
T = Sheets("AA").Range("c1")
U = Sheets("AA").Range("d1")
Ar = Sheets("AA").Range("b3:i19")
With Sheets("QQ")
     Arr = .Range("a1:h" & .[b65536].End(3).Row) 'T1   T1,T2,T3請自行選擇更換
    'Arr = .Range("j1:q" & .[k65536].End(3).Row) 'T2
     'Arr = .Range("s1:z" & .[t65536].End(3).Row) 'T3
     For i = 1 To UBound(Arr) Step 19
         T1 = Arr(i, 2): If T1 = "" Then GoTo 99
         If T1 = T Then
             .Cells(i, 1).Offset(1).Resize(16, 8).Value = Ar
             Exit Sub
         End If
99:   Next
End With
End Sub

接下來就不知道怎麼用，不知道是不是這樣改。

samwang

回復 4# zz0660

不好意思，可否請解釋詳細一點，謝謝

zz0660

回復 5# samwang


    您好，現在想把按鈕換成下拉式選單的方式，當d1欄位讀取到選單內容為T1，就會顯示QQ表單的相對應位置。

samwang

回復 6# zz0660

請測試看看，謝謝
Sub test_T1()
Dim Arr, T, xR, T1, i&, j&, xC%
With Sheets("AA")
    T = .Range("c1"): xR = .Range("d1")
    Ar = .Range("b3:i19")
End With
With Sheets("QQ")
    If xR = "T1" Then
        Arr = .Range("a1:h" & .[b65536].End(3).Row): xC = 0 'T1
    ElseIf xR = "T2" Then
        Arr = .Range("j1:q" & .[k65536].End(3).Row): xC = 9 'T2
    ElseIf xR = "T3" Then
        Arr = .Range("s1:z" & .[t65536].End(3).Row): xC = 18 'T3
    End If
     For i = 1 To UBound(Arr) Step 19
         T1 = Arr(i, 2): If T1 = "" Then GoTo 99
         If T1 = T Then
             .Cells(i, 1).Offset(1, xC).Resize(17, 8).Value = Ar
             Exit Sub
         End If
99:   Next
End With
End Sub

zz0660

回復 7# samwang


    感謝您協助處理問題，目前使用該程式碼，沒有任何反應，在此提供檔案。
QQA.rar (25.51 KB)

下載次數: 4

2021-7-29 22:55

麻煩您了，謝謝!

samwang

回復 8# zz0660

我測試沒問題如附件，可否再講詳細一點，謝謝

zz0660

回復 9# samwang

請問您把程式碼放在哪裡?

下載 (159.71 KB)

2021-7-30 10:49

是AA工作表，還是另外開一個模組呢?