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

標題: [發問] 如資料行、列數不一定如何統一合併為兩攔且以空格分開 [打印本頁]

作者: billchenfantasy 時間: 2013-2-18 14:16 標題: 如資料行、列數不一定如何統一合併為兩攔且以空格分開

[attach]14183[/attach]
呈上因資料筆數較多請各位前輩賜教感恩

作者: luhpro 時間: 2013-2-18 23:42

呈上因資料筆數較多請各位前輩賜教感恩
billchenfantasy 發表於 2013-2-18 14:16

觀看你舉例的結果與上方原稿內容似乎有部分地方無法對應,例如 :
M12 雖然有對應 2002/9/24
但找不到 M63 (0-0 2-2) 裡的 2-2 (M64 是 1974/8/22 2002/9/24)
故假設你原稿中 Plan_Dat_5 與 Plan_Dat_6 (即 L 欄與 M 欄間)中間有一欄被誤刪了.
底下的程式是以此假設為基礎做出來的.

Sub ex()
Dim iCols%, iCol%
Dim lRows As Long, lRow As Long
iCols = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Columns(iCols - 1), Columns(iCols)).Cut
Columns(3).Insert xlShiftToRight
lRows = Cells(Rows.Count, 1).End(xlUp).Row
For lRow = 2 To lRows
For iCol = 3 To iCols Step 2
If Cells(lRow, iCol) <> "" Then
Cells(lRow, 1) = Cells(lRow, 1) & " " & Cells(lRow, iCol)
Cells(lRow, iCol) = ""
Cells(lRow, 2) = Cells(lRow, 2) & " " & Cells(lRow, iCol + 1)
Cells(lRow, iCol + 1) = ""
End If
Next iCol
Next lRow
End Sub

複製代碼

作者: Hsieh 時間: 2013-2-19 00:36

回復 1# billchenfantasy
是否也要排除重複?

Sub ex()
Dim Rng As Range, A As Range, C As Range
Set d = CreateObject("Scripting.Dictionary")
d("first") = Array("Mplan_no", "Mdate")
[A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut
[C1].Insert
For Each A In Range([A2], [A2].End(xlDown))
mystr = "": x = "": y = ""
Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)
For Each C In Rng
mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C)
x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))
y = IIf(y = "", C, y & " " & C)
Next
d(mystr) = Array(x, y)
Next
[C:D].Cut [A1].End(xlToRight).Offset(, 1)
[C:D].Delete
[A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
End Sub

複製代碼

作者: billchenfantasy 時間: 2013-2-19 10:21

回復 2# luhpro [/b
謝謝您的答覆與指導，確實會因計算導致誤刪的狀況發生，感謝您的細心。
您的公式在使用過後，補齊2-2那一欄的狀況下可以將資料整理至欲達成的格式。
[attach]14186[/attach]
然而在沒有補齊的狀況下，則會發生以下狀況
[attach]14187[/attach]
您的公式我會好好學習，再次感謝
作者: billchenfantasy 時間: 2013-2-19 10:44

回復 3# Hsieh
感謝您的答覆與協助，原來有這麼多寫法可以參考
而在嘗試運用您的公式時，發現並未先將最後兩攔剪下移至0-2之前
是否是須將後三行的指令順序移動呢?
感恩
作者: billchenfantasy 時間: 2013-2-19 10:47

回復 5# billchenfantasy

補充一點_資料是不需移除重複的謝謝您
作者: Hsieh 時間: 2013-2-19 11:05

回復 6# billchenfantasy

若依你的範例說明是要移除重複(原22列資料，整理後為15列)
是有先將最末2欄向前移動，只是有再恢復原貌而以
Sub ex()

Dim Rng As Range, A As Range, C As Range

Set d = CreateObject("Scripting.Dictionary")

d("first") = Array("Mplan_no", "Mdate") '新標題

[A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut  '最後2欄剪下

[C1].Insert  '在C欄插入剪下的儲存格

For Each A In Range([A2], [A2].End(xlDown))

mystr = "": x = "": y = ""

  Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)  '以日期作為基準

  For Each C In Rng

   'mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C) '若要排除重複則使用此為字典索引

   x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))

   y = IIf(y = "", C, y & " " & C)

  Next

  s = s + 1

  d(s) = Array(x, y)

  'd(mystr) = Array(x, y)  '若要排除重複則使用此為字典索引

Next

[C:D].Cut [A1].End(xlToRight).Offset(, 1)  '將C:D欄剪下貼回資料表最末端

[C:D].Delete  'C:D剪下後變成空白欄，所以將其刪除，回覆成原資料表

[A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))

End Sub
複製代碼
作者: billchenfantasy 時間: 2013-2-19 11:46

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

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

Dim Rng As Range, A As Range, C As Range

Set d = CreateObject("Scripting.Dictionary")

d("first") = Array("Mplan_no", "Mdate") '新標題

[A1].End(xlToRight).Offset(, -1).Resize(, 2).EntireColumn.Cut  '最後2欄剪下

[C1].Insert  '在C欄插入剪下的儲存格

For Each A In Range([A2], [A2].End(xlDown))

mystr = "": x = "": y = ""

  Set Rng = A.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers)  '以日期作為基準

  For Each C In Rng

   'mystr = IIf(mystr = "", C.Offset(, -1) & C, mystr & C.Offset(, -1) & C) '若要排除重複則使用此為字典索引

   x = IIf(x = "", C.Offset(, -1), x & " " & C.Offset(, -1))

   y = IIf(y = "", C, y & " " & C)

  Next

  If InStr(x, "0-0") > 0 Then '整列中不含"0-0"

  s = s + 1

  d(s) = Array(x, y)

  End If



  'd(mystr) = Array(x, y)  '若要排除重複則使用此為字典索引

Next

[C:D].Cut [A1].End(xlToRight).Offset(, 1)  '將C:D欄剪下貼回資料表最末端

[C:D].Delete  'C:D剪下後變成空白欄，所以將其刪除，回覆成原資料表

[A1].End(xlDown).Offset(3).Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))

End Sub
複製代碼
作者: billchenfantasy 時間: 2013-2-19 16:15

回復 9# Hsieh

謝謝您的指導我會將您的程式寫法和手邊其他資料統整一下，加入字典判斷的準則。好好研究一番，感謝您
作者: billchenfantasy 時間: 2013-3-7 14:40

回復 9# Hsieh

不好意思關於這篇的延伸可以再請教您以下的問題嗎
這是我延續這篇答覆自行更改撰寫由VBA跑出的結果
資料欄、列長度不一定但固定由D這攔起始
請問要怎麼在程式尾端在加幾項讓D攔後所有資料在MDATE_T這攔整理成左邊MDATE的格式
1 自動選擇D攔以後攔、列上有資料的全部範圍
2 在C2下方合併起來
[attach]14292[/attach]
作者: Hsieh 時間: 2013-3-7 14:58

回復 11# billchenfantasy
是這個意思嗎?
Sub ex()

Dim Ar()

r = 2

Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0

Set a = Cells(r, "D")

Set rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)

For Each c In rng

ReDim Preserve Ar(s)

Ar(s) = Format(c, "yyyy/m/d")

s = s + 1

Next

a.Offset(, -1) = Join(Ar, " ")

Erase Ar: s = 0

r = r + 1

Loop

End Sub
複製代碼
作者: billchenfantasy 時間: 2013-3-7 17:13

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

回復 13# billchenfantasy

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

Dim Ar()

r = 2

Do Until Application.CountA(Range(Cells(r, 4), Cells(r, Columns.Count))) = 0

Set a = Cells(r, "D")

Set Rng = Range(a, Cells(r, Columns.Count)).SpecialCells(xlCellTypeConstants)

For Each c In Rng

ReDim Preserve Ar(s)

Ar(s) = Format(c, "e/m/d")

s = s + 1

Next

a.Offset(, -1) = Join(Ar, " ")

Erase Ar: s = 0

r = r + 1

Loop

End Sub
複製代碼
作者: billchenfantasy 時間: 2013-3-8 10:23

回復 14# Hsieh
感謝您的幫助可以順利執行了~ 謝謝
作者: Andy2483 時間: 2023-4-12 16:21

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

執行前:
[attach]36123[/attach]

執行結果:
[attach]36124[/attach]

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

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