接續記錄資料 - Excel程式區 - 麻辣家族討論版版

帖子: 2808
主題: 10
精華: 0
積分: 2864
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-10

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

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2808
主題: 10
精華: 0
積分: 2864
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-5-10

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

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 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 | 只看該作者

也可以這樣寫

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

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

kim223824

中學生 Rank: 2

帖子: 75
主題: 8
精華: 0
積分: 109
點名: 0
作業系統: windows XP
軟體版本: office 2010
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2015-4-19
最後登錄: 2023-5-2

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