[發問] 如資料行、列數不一定如何統一合併為兩攔且以空格分開

billchenfantasy

資料說明.rar (10.54 KB)

資料說明
下載次數: 20

2013-2-18 14:13

呈上 因資料筆數較多 請各位前輩賜教 感恩

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

billchenfantasy

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

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

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

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

回復 9# Hsieh


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

下載次數: 7

2013-3-7 14:39

billchenfantasy

回復 9# Hsieh


    謝謝您的指導我會將您的程式寫法和手邊其他資料統整一下，加入字典判斷的準則。好好研究一番，感謝您

Hsieh

回復 8# billchenfantasy
不知是否可以再請教若將"重複的資料刪除"這項改為將無0-0的那一列刪除   
你說本例中是人工比對刪除不含0-0的列
但是，原資料A欄都是0-0，為何是刪除不含0-0?
若排除不含0-0的列，就在加入字典時判斷是否含有0-0

1. Sub ex()
   
2. Dim Rng As Range, A As Range, C As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. d("first") = Array("Mplan_no", "Mdate")    '新標題
   
5. [A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut  '最後2欄剪下
   
6. [C1].Insert  '在C欄插入剪下的儲存格
   
7. For Each A In Range([A2], [A2].End(xlDown))
   
8. mystr = "": x = "": y = ""
   
9.   Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)  '以日期作為基準
   
10.   For Each C In Rng
    
11.      'mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C) '若要排除重複則使用此為字典索引
    
12.      x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))
    
13.      y = IIf(y = "", C, y & " " & C)
    
14.   Next
    
15.   If InStr(x, "0-0") > 0 Then '整列中不含"0-0"
    
16.   s = s + 1
    
17.   d(s) = Array(x, y)
    
18.   End If
    
19.   
    
20.   'd(mystr) = Array(x, y)  '若要排除重複則使用此為字典索引
    
21. Next
    
22. [C:D].Cut [A1].End(xlToRight).Offset(, 1)  '將C:D欄剪下貼回資料表最末端
    
23. [C:D].Delete  'C:D剪下後變成空白欄，所以將其刪除，回覆成原資料表
    
24. [A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
    
25. End Sub

複製代碼

billchenfantasy

回復 7# Hsieh
謝謝您的詳細答覆@@原來如此
在範例中的結果是將無0-0的行與完成整理後的資料經人為比對後刪除的結果
由於每次取得之資料整理後均必需經過人為的比對再行刪除一些資料(列)
有時會有某些列資料重複的特例發生
故才會不需自程式中先行刪除
在範例中沒有詳細說明在此說聲抱歉，也感謝您的細心
不知是否可以再請教若將"重複的資料刪除"這項改為將無0-0的那一列刪除
中間的程式碼可以如何更改ㄋ 謝謝