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

標題: [發問] 接續記錄資料 [打印本頁]

作者: PJChen 時間: 2019-9-9 17:10 標題: 接續記錄資料

本帖最後由 PJChen 於 2019-9-9 17:11 編輯

請教高手們：
我想在在K欄讀取A~G的資料
依序為A、B、C…欄位的順序
每個欄位的讀取為從上到下
數據長度不一定,有可能增加
讀取時，每一欄遇0或空格，自動讀取下一欄
但在K欄的顯示結果都要一直增加下去
也就是當資料欄數或列數增加時,K欄資料都要能讀取到並接續記錄
我想用VBA寫這種讀取方式，請問要怎麼寫這種

作者: hcm19522 時間: 2019-9-10 10:07

https://blog.xuite.net/hcm19522/twblog/588250550

作者: PJChen 時間: 2019-9-10 22:26

回復 2# hcm19522

感謝你的回覆,但我想學VBA語法
感覺在這裡發問，越來越得不到回應了....

作者: kim223824 時間: 2019-9-14 14:34

回復 1# PJChen

[attach]31261[/attach]

Sub test_20190914()
'確認顯示結果的最後一欄位置
ROW1 = Sheets("顯示結果").Cells(Rows.Count, "A").End(3).Row

'如果最後一欄 > 1表示有資料
If ROW1 > 1 Then
      '將資料清除
      Sheets("顯示結果").Range("A2:A" & ROW1).Clear
End If

'判斷有幾列=========
COL1 = Range("A1").End(xlToRight).Column

'顯示結果由第2列開始===================
k = 2

'列的迴圈==========
For i = 1 To COL1

      '判斷每一欄的最後一個位置
      ROW2 = Cells(Rows.Count, i).End(3).Row
      '欄的迴圈==========
      For j = 1 To ROW2

         '判斷欄位內容不是 "0" 的時候執行內容
         If Cells(j, i) <> 0 Then
            '將欄位的值給顯示結果的欄位
            Sheets("顯示結果").Cells(k, "A").Value = Cells(j, i).Value
            '往下加一欄
            k = k + 1
         End If

      Next
Next

End Sub

作者: PJChen 時間: 2019-9-14 20:29

回復 4# kim223824

真感謝你,目前測試OK,我再好好研究一下,有問題的話再請教你。

再次謝謝....

作者: GBKEE 時間: 2019-9-16 11:32

也可以這樣寫

Option Explicit
Sub EX()
Dim Rng As Range, M As Variant, c As Range, r As Range
Set Rng = Sheets("K欄讀取資料").Range("a1").CurrentRegion
M = "顯示結果"
For Each c In Rng.Columns 'Columns 範圍的Column集合物件
For Each r In c.Cells 'Cells 範圍的Cell集合物件
If r = "" Or r = 0 Then Exit For
M = M & "," & r
Next
Next
M = Split(M, ",")
With Sheets("顯示結果").Range("a1")
.CurrentRegion.Clear
.Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
End With
End Sub

複製代碼

作者: 准提部林 時間: 2019-9-16 13:36

Sub TEST01()
Dim Arr, Brr, r&, c%, N&
[K2:K20000].ClearContents
Arr = Intersect([A:G], ActiveSheet.UsedRange)
ReDim Brr(1 To UBound(Arr) * UBound(Arr, 2), 0)
For c = 1 To UBound(Arr, 2)
For r = 1 To UBound(Arr)
If Arr(r, c) = 0 Or Arr(r, c) = "" Then Exit For
N = N + 1: Brr(N, 0) = Arr(r, c)
Next r
Next c
If N > 0 Then [K2].Resize(N) = Brr
End Sub

====================

作者: 准提部林 時間: 2019-9-16 13:44

本帖最後由准提部林於 2019-9-16 13:48 編輯

Sub TEST02()
Dim xC As Range, xR As Range, N&
[K2:K20000].ClearContents
For Each xC In [A1].CurrentRegion.Columns
For Each xR In xC.Cells
If xR = 0 Or xR = "" Then Exit For
N = N + 1: [K2].Cells(N, 1) = xR
Next: Next
End Sub

=======================

作者: PJChen 時間: 2019-9-16 23:17

回復 6# GBKEE
回復 8# 准提部林

感謝二位大大熱情的提供程式，供我得以研究三種不同寫法，執行真的很快速，感謝+++
<(￣︶￣)>

作者: PJChen 時間: 2019-9-16 23:55

回復 6# GBKEE

請教G大：
資料中的表頭因為有帶公式,第一列的代號,我不想該它顯示在讀取的欄位(aw)中,請問要如何修改這句 Set Rng = Sh.Range("aw2").CurrentRegion,讓它不讀取第1列?

[attach]31267[/attach]

Sub Ex()
Dim Rng As Range, M As Variant, c As Range, r As Range, W As Workbook, Sh As Worksheet
Set W = Workbooks("最新庫存.xlsx")
Set Sh = W.Sheets("廠缺表")
'------------------------------GBKEE
Set Rng = Sh.Range("aw2").CurrentRegion '來源區域從aw2~現行使用區塊
M = "廠缺Text"
For Each c In Rng.Columns 'Columns 範圍的Column集合物件
For Each r In c.Cells 'Cells 範圍的Cell集合物件
If r = "" Or r = 0 Then Exit For '遇空格or 0程式便跳下一欄,直到資料結束
M = M & "," & r
Next
Next
M = Split(M, ",")
With Sh.Range("bm1") '將讀取資料,顯示到BM欄
.CurrentRegion.Clear
.Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
End With
End Sub

複製代碼

作者: GBKEE 時間: 2019-9-18 09:48

回復 10# PJChen

With Sh.Range("aw1").CurrentRegion
Set Rng = Range(.Rows(2), .Rows(.Rows.Count))
End With

複製代碼

作者: PJChen 時間: 2019-9-18 22:00

回復 11# GBKEE
G大,
VBA是放在另一個程式中,執行時程式卡在紅色字那段,說是型態不符,請幫忙看下問題,感謝！ [attach]31275[/attach]

Sub 廠缺Text()
Dim Rng As Range, M As Variant, c As Range, r As Range, W As Workbook, Sh As Worksheet
Set W = Workbooks("最新庫存.xlsx")
Set Sh = W.Sheets("廠缺表")
With Sh.Range("aw1").CurrentRegion
Set Rng = Range(.Rows(2), .Rows(.Rows.Count)) '來源區域不讀取第1列,設定從第2列開始讀取
M = "廠缺Text" '設定M為接收資料的變數,表頭為""內的文字,可任意更改
For Each c In Rng.Columns 'Columns 範圍的Column集合物件
For Each r In c.Cells 'Cells 範圍的Cell集合物件
[color=Red] If r = "" Or r = 0 Then Exit For[/color] '遇空格or 0程式便跳下一欄,直到資料結束
M = M & "," & r
Next
Next
M = Split(M, ",")
End With
With Sh.Range("bm1") '將讀取資料,顯示到BM欄
.CurrentRegion.Clear
.Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
End With
End Sub

複製代碼

作者: GBKEE 時間: 2019-9-19 13:04

回復 12# PJChen

Option Explicit
Sub 廠缺Text()
Dim Rng As Range, M As Variant, W As Workbook, Sh As Worksheet, i As Integer
Set W = Workbooks("最新庫存.xlsx")
Set Sh = W.Sheets("廠缺表")
'** 你檔案的資料不適用 'Range.CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。
** '目前區域是指以任意空白列及空白欄的組合為邊界的範圍
With Sh.Range("aw1").CurrentRegion
Set Rng = Range(.Rows(2), .Rows(.Rows.Count)) '來源區域不讀取第1列,設定從第2列開始讀取
Rng.Cells(1, 5).Select
MsgBox "你檔案不適用 CurrentRegionRng" & vbLf & Rng.Address(, , , 1, 1) & vbLf & Selection.Address(0, 0) & "錯誤值造成程錯誤"
End With
M = "廠缺Text" '設定M為接收資料的變數,表頭為""內的文字,可任意更改
Set Rng = Sh.Range("aw2")
Do Until Rng.Text = "" Or Rng.Text = 0 Or IsError(Rng)
i = 1
Do While Rng(i).Text <> "" And Rng(i).Text <> 0 And Not IsError(Rng(i))
M = M & "," & Rng(i) '第i個處存格
i = i + 1
Loop
Set Rng = Rng.Offset(, 1) '**左移一欄
Loop
M = Split(M, ",")
With Sh.Range("bm:bm") '將讀取資料,顯示到BM欄
.Clear
.Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
End With
End Sub

複製代碼

作者: PJChen 時間: 2019-9-19 21:00

回復 13# GBKEE
Dear G大,
執行過程停在這裡,請問該如何改?
Rng.Cells(1, 5).Select

[attach]31280[/attach]

作者: GBKEE 時間: 2019-9-20 08:41

回復 14# PJChen
明白如何錯誤後這段程式碼刪除

With Sh.Range("aw1").CurrentRegion
Set Rng = Range(.Rows(2), .Rows(.Rows.Count)) '來源區域不讀取第1列,設定從第2列開始讀取
Rng.Cells(1, 5).Select '********將視窗移到 [ 最新庫存.xlsx] 再執行程式試試看******
MsgBox "你檔案不適用 CurrentRegionRng" & vbLf & Rng.Address(, , , 1, 1) & vbLf & Selection.Address(0, 0) & "錯誤值造成程錯誤"
End With

複製代碼

是要你

作者: PJChen 時間: 2019-9-20 21:33

回復 15# GBKEE
感謝G大,

執行沒問題了^.^

作者: PJChen 時間: 2019-10-5 19:35

回復 6# GBKEE

請問G大,

我有另一表格需要類似這樣的轉貼,但不要貼成同一欄,而是依原資料的欄數去轉貼,但資料遇0或各種錯誤值 #N/A!、#VALUE!、#DIV/O!都略過不取(如同貼圖)
直到"空白",則代表整欄資料結束
本來想試著自行修改,但試了很久都改不出來,,請問我要如何修改程式?

Option Explicit
Sub EX()
Dim Rng As Range, M As Variant, c As Range, r As Range
Set Rng = Sheets("K欄讀取資料").Range("a1").CurrentRegion
M = "顯示結果"
For Each c In Rng.Columns 'Columns 範圍的Column集合物件
For Each r In c.Cells 'Cells 範圍的Cell集合物件
If r = "" Or r = 0 Then Exit For
M = M & "," & r
Next
Next
M = Split(M, ",")
With Sheets("顯示結果").Range("a1")
.CurrentRegion.Clear
.Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
End With
E

複製代碼

[attach]31313[/attach]
[attach]31316[/attach]

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