麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 複製資料轉寫到另一工作表 [打印本頁]

作者: yliu 時間: 2013-7-22 23:36 標題: ListBox 清單內的資料寫入工作表上的儲存格

請教高手,
如何將ListBox 清單內的資料寫入工作表上的儲存格,如圖,
選取序號001,002後,資料呈現於儲存格A9:E10.
[attach]15522[/attach][attach]15523[/attach]

作者: Hsieh 時間: 2013-7-23 09:34

回復 1# yliu

Private Sub ListBox1_Change()
Dim ar()
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
ReDim Preserve ar(s)
ar(s) = Array(i + 1, .List(i, 0), .List(i, 1), .List(i, 2), .List(i, 3))
s = s + 1
End If
Next
End With
[A9:E19] = ""
If s > 0 Then [A9].Resize(s, 5) = Application.Transpose(Application.Transpose(ar))
End Sub

複製代碼

作者: yliu 時間: 2013-7-23 20:37

回復 2# Hsieh

感謝Hsieh版大的幫忙，可以使用了，謝謝！

作者: yliu 時間: 2013-7-24 00:01 標題: 複製資料轉寫到另一工作表

請問版上高手,
寫了一個VBA,要將一工作表上資料轉寫到另一工作表,結果都只有複製1筆資料,請幫忙看一下是哪裡有問題.
[attach]15532[/attach][attach]15533[/attach]

作者: GBKEE 時間: 2013-7-24 07:24

回復 4# yliu

Private Sub CommandButton1_Click()
Dim rowcnt&, rowcnt_login&
Dim g As Integer, 序號 As Range, I As Integer
Set 序號 = Sheets("login").[B9:J19] '物件 : 設定複製的範圍
g = Application.CountA(Sheets("final").[A:A]) + 1 '讀取A欗有資料數的儲存格數 +1
I = 1
Do Until 序號.Range("A" & I) = "" Or I > 序號.Rows.Count
'範圍的 Range("A" & I)->範圍的"A"欗 ,Rows.Count;範圍列數的計算
With Sheets("final")
.Cells(g, "A") = Sheets("login").ComboBox1.Value
.Cells(g, "B").Resize(1, 序號.Columns.Count) = 序號.Rows(I).Value
g = g + 1
I = I + 1
End With
Loop
End Sub

複製代碼

作者: yliu 時間: 2013-7-24 17:39

回復 5# GBKEE

GBKEE你好,
請問若複製範圍不是連續範圍時, 該怎麼做?
例如: 目的地工作表”final”的C欄『規格』刪除, 來源工作表是連續範圍, 但目的地工作表不是連續範圍時.

作者: GBKEE 時間: 2013-7-24 20:10

回復 6# yliu

Private Sub CommandButton1_Click()
Dim g As Integer, E As Range
g = Application.CountA(Sheets("final").[A:A]) + 1 '讀取A欗有資料數的儲存格數 +1
For Each E In Sheets("login").[B9:B19]
If E = "" Then Exit For
With Sheets("final")
.Cells(g, "A") = Sheets("login").ComboBox1.Value
.Cells(g, "B").Resize(1, 2) = E.Resize(1, 2).Value
.Cells(g, "D").Resize(1, 6) = E.Cells(1, 4).Resize(1, 6).Value
End With
g = g + 1
Next
End Sub

複製代碼

作者: yliu 時間: 2013-7-24 23:33

回復 7# GBKEE

真的很謝謝GBKEE, 以及上次幫忙的Hsieh.
想藉由Excel VBA來解決工作上一些繁瑣的資料處理,但我只學過基本的VBA, 功力實在不足,
感激版主們無私的解答,讓我解決工作上問題.

作者: yliu 時間: 2013-8-2 00:05

回復 7# GBKEE

GBKEE版大,
延伸另一個問題, 使用ListBox ,請問如何讓已選取且已COPY到工作表"final"的單號&序號不會再次被選取COPY?

[attach]15670[/attach]

作者: GBKEE 時間: 2013-8-3 14:20

回復 9# yliu

Private Sub CommandButton1_Click()
Dim g As Integer, E As Range, C As Range, 單號 As String, SS As String, Rng As Range
Dim i As Integer
With Sheets("login")
單號 = .ComboBox1.Value
Set Rng = .[B9:B19]
SS = Application.Phonetic(Rng) '結合所有序號
End With
With Sheets("final").[A:A]
If Application.CountIf(.Cells, 單號) > 1 Then
.Replace 單號, "=xxx", xlWhole ''Replace 方法
With .SpecialCells(xlCellTypeFormulas, xlErrors)
.Cells = 單號
For Each C In .Cells ''比對到序號踢除此序號
If InStr(SS, C.Offset(, 1)) Then SS = Replace(SS, C.Offset(, 1), "") 'Replace 函數
If SS = "" Then Exit Sub
Next
End With
End If
For Each E In Rng
If E = "" Then Exit For
If InStr(SS, E) Then '比對到序號
g = Application.CountA(.Cells) + 1 '讀取A欗有資料數的儲存格數 +1
i = Application.CountA(Rng)
.Cells(g, "A").Resize(1) = 單號
.Cells(g, "B").Resize(1, 2) = E.Cells(1).Resize(1, 2).Value
.Cells(g, "D").Resize(1, 6) = E.Cells(1, 4).Resize(1, 6).Value
End If
Next
End With
End Sub

複製代碼

作者: yliu 時間: 2013-8-7 23:38

回復 10# GBKEE

謝謝GBKEE!

作者: yliu 時間: 2013-8-29 23:55

有兩個ListBox, 一個是單號(ListBox2), 一個是單號明細(ListBox1),都可以複選, 請詳附件[attach]15884[/attach]
想請問版上高手, ListBox2的程式是否有更好的寫法?
我目前寫法是:
Private Sub ListBox2_Change()
Dim lrow, irow, ai As Integer
Sheets("login").ListBox1.Clear
[A9:E19] = ""
With ListBox2

For lrow = 0 To .ListCount - 1

  If .Selected(lrow) Then
With Sheets(Sh)
   ai = 2
   Do While .Cells(ai, "A") <> ""
If .Cells(ai, "A") = ListBox2.List(lrow, 0) Then
   With ListBox1
      .AddItem
      irow = .ListCount
   .List(irow - 1, 0) = Sheets(Sh).Cells(ai, "A")
   .List(irow - 1, 1) = Sheets(Sh).Cells(ai, "B")
   .List(irow - 1, 2) = Sheets(Sh).Cells(ai, "C")
   .List(irow - 1, 3) = Sheets(Sh).Cells(ai, "D")
   .List(irow - 1, 4) = Sheets(Sh).Cells(ai, "E")
      End With
   End If
ai = ai + 1
Loop
End With
End If
Next
End With
Application.EnableEvents = True
End Sub

作者: c_c_lai 時間: 2013-8-30 08:50

回復 12# yliu
套用你原本的檔案，並加以稍稍修改，看看是否符合你的需求。
請觀察 ThisWorkbook 與 Sheet1 (login) 間之互動。
P.S. 另額外增加了 Checkbox 的應用，供參考。
[attach]15885[/attach]

作者: yliu 時間: 2013-8-30 12:11

回復 13# c_c_lai

不好意思, 我要的是2個ListBox都能複選, 也就是單號的ListBox複選完後(跨單號,不是單一), 其明細都會出現在明細的ListBox, 然後再去勾選要的序號明細.
我的寫法太多層,希望能簡化. 不知是否提供較好的寫法.檔案是昨天貼上的那個檔案. 謝謝~

作者: c_c_lai 時間: 2013-8-30 12:19

回復 14# yliu
你要的是圈起來的部分，附上的是全部的 (ComboBox、CheckBox、ListBox1、ListBox2)應用。
請參考裡面相關的程式碼：
[attach]15894[/attach]

作者: yliu 時間: 2013-8-30 13:19

回復 15# c_c_lai
不好意思, 現在無法上傳圖片, 只能先用文字敘述
我想只要用2個ListBox 完成選項, 太多物件會佔空間,我的做法是:
單號的[List Box2] 可一次勾選單號TW-1301001及TW1301002
明細的[List Box1]就會出現共4筆序號明細TW-1301001 001, TW-1301001 002, TW-1301001 003, TW-1301002 001
只是希望想用別的寫法簡化我的多層迴圈判斷.

作者: c_c_lai 時間: 2013-8-30 14:43

回復 16# yliu
上頭附上的檔案是完全涵蓋你的 ListBox問題(2).zip 的需求，
原本是想讓你自己嘗試從中掘取出來，所以才會上傳圖片告訴你圈出的部分，
它是支很好的範例。想想還是把其它部分(案例)移除，取出你要的需求。
[attach]15895[/attach]
[attach]15896[/attach]

作者: c_c_lai 時間: 2013-8-30 15:22

本帖最後由 c_c_lai 於 2013-8-30 15:25 編輯

回復 16# yliu
#17 樓是單選，你也可以改為多選：

Private Sub CommandButton1_Click()
Dim g As Integer, E As Range, C As Range, 單號 As String, SS As String, Rng As Range
Dim i As Integer
With Sheets("login")
單號 = .ListBox2.Value
Set Rng = .[B14:B24]
SS = Application.Phonetic(Rng) ' 結合所有序號
End With
With Sheets("final").[A:A]
If Application.CountIf(.Cells, 單號) > 1 Then
.Replace 單號, "=xxx", xlWhole ' Replace 方法
With .SpecialCells(xlCellTypeFormulas, xlErrors)
.Cells = 單號
For Each C In .Cells ' 比對到序號踢除此序號
If InStr(SS, C.Offset(, 1)) Then SS = Replace(SS, C.Offset(, 1), "") ' Replace 函數
If SS = "" Then Exit Sub
Next
End With
End If
For Each E In Rng
If E = "" Then Exit For
If InStr(SS, E) Then ' 比對到序號
g = Application.CountA(.Cells) + 1 ' 讀取A欗有資料數的儲存格數 +1
i = Application.CountA(Rng)
.Cells(g, "A").Resize(1) = 單號
.Cells(g, "B").Resize(1, 2) = E.Cells(1).Resize(1, 2).Value
.Cells(g, "D").Resize(1, 6) = E.Cells(1, 4).Resize(1, 6).Value
End If
Next
End With
With Sheets("login")
.ListBox1.Clear
.[A14:E24] = ""
.ListBox2 = ""
End With
End Sub

複製代碼

增加最後五行 (37 ~ 41)。

Private Sub ListBox2_Change()
Dim i As Integer, R As Integer
' ListBox1.Clear
Sheets("login").[A14:E24] = ""

複製代碼

將 ListBox1.Clear Remark 起來。

作者: c_c_lai 時間: 2013-8-30 15:23

回復 c_c_lai
不好意思, 現在無法上傳圖片, 只能先用文字敘述
我想只要用2個ListBox 完成選項, 太多物件 ...
yliu 發表於 2013-8-30 13:19

[attach]15899[/attach]
這便是你要的 (多選)

作者: yliu 時間: 2013-9-1 23:13

回復 19# c_c_lai
抱歉, 依你所提供的,不是我要的複選. 我想應該是我表達的意思不夠清楚,
我要的複選如圖;
[attach]15912[/attach]

作者: c_c_lai 時間: 2013-9-2 05:19

回復 20# yliu
如果妳將 MultiSelect: - fmMultiSelectSingle 改成 fmMultiSelectMulti
如此 ListBox2 對應之 ListBox2_Change() 則將無任何作用，
是故你必須使用另外的方式來處理妳的勾選項，反之、
在每次勾選時都會觸動 ListBox2_Change() 。

作者: GBKEE 時間: 2013-9-2 09:12

本帖最後由 GBKEE 於 2013-9-4 11:14 編輯

回復 12# yliu

Private Sub ListBox2_Change()
Dim lrow, irow, ai As Integer, AR, S As String
With ListBox1
AR = .List '.List-> ( 0 TO .ListCount - 1, 0 TO 9) ListBox的ColumnCount 屬性最多只能有 10 行 (0 到 9)。
'這ListBox1只有4行資料,後面的5行-9行 = Null,使用Index 函數會錯誤
If .ListCount > 0 Then ReDim Preserve AR(0 To .ListCount - 1, 0 To .ColumnCount - 1) '消除後面的5行-9行的 Null
For lrow = 0 To .ListCount - 1
If .Selected(lrow) Then
S = S & Join(Application.Index(AR, lrow + IIf(UBound(AR) = 0, 0, 1)), "") '紀錄已勾選的資料
End If
Next
.Clear
End With
[A9:E19] = ""
With ListBox2
For lrow = 0 To .ListCount - 1
If .Selected(lrow) Then
With Sheets(Sh)
ai = 2
Do While .Cells(ai, "A") <> ""
If .Cells(ai, "A") = ListBox2.List(lrow, 0) Then
With ListBox1
.AddItem
irow = .ListCount
.List(irow - 1, 0) = Sheets(Sh).Cells(ai, "A")
.List(irow - 1, 1) = Sheets(Sh).Cells(ai, "B")
.List(irow - 1, 2) = Sheets(Sh).Cells(ai, "C")
.List(irow - 1, 3) = Sheets(Sh).Cells(ai, "D")
.List(irow - 1, 4) = Sheets(Sh).Cells(ai, "E")
If InStr(S, Application.Phonetic(Sheets(Sh).Cells(ai, "A").Resize(, 5))) Then '比對: 紀錄已勾選的資料
.Selected(.ListCount - 1) = True
End If
End With
End If
ai = ai + 1
Loop
End With
End If
Next
End With
End Sub

複製代碼

作者: yliu 時間: 2013-9-3 23:03

回復 22# GBKEE
GBKEE版大,
出現型態不符的錯誤訊息, 在AR = .List '.List-> ( 0 TO .ListCount - 1, 0 TO 9) ListBox的ColumnCount 屬性最多只能有 10 行 (0 到 9)。

作者: GBKEE 時間: 2013-9-4 11:13

回復 23# yliu
請修改如下
Dim lrow, irow, ai As Integer, AR(), S As String -> Dim AR
If UBound(AR) > -1 Then ReDim -> If .ListCount > 0 Then ReDim

作者: yliu 時間: 2013-9-4 23:00

回復 24# GBKEE
感謝GBKEE, 改善原程式碼的缺點. 謝謝你的幫忙.

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