12
返回列表 上一主題 發帖

[發問] 接續記錄資料

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2019-9-9 17:10 | 只看該作者

[發問] 接續記錄資料

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

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

20190909.170733.jpg (138.31 KB)

20190909.170733.jpg

K欄接續記錄.rar (7.66 KB)

收藏 分享

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-24 

熱烈參與勳章
2#
發表於 2019-9-10 10:07 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/588250550
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2019-9-10 22:26 | 只看該作者
回復 2# hcm19522

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

TOP

kim223824

帖子
75 
主題
8 
精華
0 
積分
109 
點名
0  
作業系統
windows XP 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
高雄 
註冊時間
2015-4-19 
最後登錄
2024-8-10 
4#
發表於 2019-9-14 14:34 | 只看該作者
回復 1# PJChen

K欄接續記錄.zip (103.25 KB)

    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

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
5#
發表於 2019-9-14 20:29 | 只看該作者
回復 4# kim223824

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

再次謝謝....

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2019-9-16 11:32 | 只看該作者
也可以這樣寫
  1. Option Explicit
  2. Sub EX()
  3.     Dim Rng As Range, M As Variant, c As Range, r As Range
  4.     Set Rng = Sheets("K欄讀取資料").Range("a1").CurrentRegion
  5.     M = "顯示結果"
  6.     For Each c In Rng.Columns   'Columns 範圍的Column集合物件
  7.         For Each r In c.Cells   'Cells 範圍的Cell集合物件
  8.             If r = "" Or r = 0 Then Exit For
  9.             M = M & "," & r
  10.         Next
  11.     Next
  12.     M = Split(M, ",")
  13.     With Sheets("顯示結果").Range("a1")
  14.         .CurrentRegion.Clear
  15.         .Resize(UBound(M) + 1) = Application.WorksheetFunction.Transpose(M)
  16.     End With
  17. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
7#
發表於 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


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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
8#
發表於 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

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

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
9#
發表於 2019-9-16 23:17 | 只看該作者
回復 6# GBKEE
回復 8# 准提部林

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

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
10#
發表於 2019-9-16 23:55 | 只看該作者
回復 6# GBKEE

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

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

TOP

        靜思自在 : 有多少力量就做多少事，不要心存等待，等待才會落空。
12
返回列表 上一主題