billchenfantasy

回復 9# Hsieh


不好意思關於這篇的延伸可以再請教您以下的問題嗎
這是我延續這篇答覆自行更改撰寫由VBA跑出的結果       
資料欄、列長度不一定但固定由D這攔起始       
請問要怎麼在程式尾端在加幾項讓D攔後所有資料在MDATE_T這攔整理成左邊MDATE的格式       
1        自動選擇D攔以後攔、列上有資料的全部範圍
2        在C2下方合併起來
問題.rar (9.06 KB)

下載次數: 7

2013-3-7 14:39

Hsieh

回復 11# billchenfantasy
是這個意思嗎?

1. Sub ex()
   
2. Dim Ar()
   
3. r = 2
   
4. Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0
   
5.    Set a = Cells(r, "D")
   
6.    Set rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)
   
7.    For Each c In rng
   
8.    ReDim Preserve Ar(s)
   
9.    Ar(s) = Format(c, "yyyy/m/d")
   
10.    s = s + 1
    
11.    Next
    
12.    a.Offset(, -1) = Join(Ar, " ")
    
13.    Erase Ar: s = 0
    
14.    r = r + 1
    
15. Loop
    
16. End Sub

複製代碼

billchenfantasy

回復 12# Hsieh
@@恩...請問是要把他直接接在原本的程式碼後面嗎，原本出現重複宣告的BOX，所以我就把DIM移到前面開頭，可以執行，結果格式一樣，但是民國全變成西元了，我是想保留民國日期，將其整理成MDATE那攔一樣。

Hsieh

回復 13# billchenfantasy

新問題的A、B欄資料是第一個問題整理結果，但是E蘭以後的資料應該是另外輸入
所以應該是分成兩個程序執行才對吧
至於要保持民國年格式

1. Sub ex()
   
2. Dim Ar()
   
3. r = 2
   
4. Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0
   
5.    Set a = Cells(r, "D")
   
6.    Set Rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)
   
7.    For Each c In Rng
   
8.    ReDim Preserve Ar(s)
   
9.    Ar(s) = Format(c, "e/m/d")
   
10.    s = s + 1
    
11.    Next
    
12.    a.Offset(, -1) = Join(Ar, " ")
    
13.    Erase Ar: s = 0
    
14.    r = r + 1
    
15. Loop
    
16. End Sub

複製代碼

billchenfantasy

回復 14# Hsieh
感謝您的幫助可以順利執行了~ 謝謝

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列,學習方案如下,請各位前輩指教

執行前:

下載 (151.91 KB)

2023-4-12 16:20

執行結果:

下載 (183.74 KB)

2023-4-12 16:20

Option Explicit
Sub TEST()
Dim Brr, i&, j&, T$, xR As Range, Sh As Worksheet
Set Sh = Sheets("工作表1")
Set xR = Range(Sh.[C1], Intersect(Sh.[D1].CurrentRegion, [D:G]))
Intersect(xR, [C:C]).ClearContents: Brr = xR
For i = 1 To UBound(Brr)
   T = Brr(i, 1)
   For j = 2 To UBound(Brr, 2)
      T = Replace(T & " " & Format(Brr(i, j), "e/m/d"), "  ", " ")
   Next
   Brr(i, 1) = Trim(T)
Next
xR = Brr
Set xR = Nothing: Set Sh = Nothing: Erase Brr
End Sub