marklos

中學生 Rank: 2

帖子: 63
主題: 15
精華: 0
積分: 100
點名: 0
作業系統: WINXP
軟體版本: SP3
閱讀權限: 20
註冊時間: 2011-12-22
最後登錄: 2024-8-21

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2012-4-3 19:25 | 只看該作者

[發問] 相同資料欄位刪除/指定資料列重新排列

本帖最後由 marklos 於 2012-4-3 19:28 編輯

請求幫忙~
Sheet1 變成Sheet2
(相同資料欄位刪除,黃色標示)

Sheet2 變成 Sheet3
(D欄如果有資料, 紅字標示 ,插入下一欄位,並複製其B/D/G/H/I欄位的資料)

結果 Sheet3

感謝幫忙

Excel-Q4.rar (9.97 KB)

樓主熱帖

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兔年全勤獎章

2^#

發表於 2012-4-3 21:24 | 只看該作者

回復 1# marklos
建議: 請在 Sheet1 A : J 欄的第一列加上資料的欄位名稱用進階篩選可得到不重複資料

Sub EX()
Sheet3.Cells.Clear
Sheet1.UsedRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet3.Range("A1"), Unique:=True
End Sub

複製代碼

(D欄如果有資料, 紅字標示 ,插入下一欄位,並複製其B/D/G/H/I欄位的資料)
看不了解 SHEET3的結果它的欄位少了一位,只有到 I欄 SHEET1的最後欄位是J欄

TOP

marklos

中學生 Rank: 2

帖子: 63
主題: 15
精華: 0
積分: 100
點名: 0
作業系統: WINXP
軟體版本: SP3
閱讀權限: 20
註冊時間: 2011-12-22
最後登錄: 2024-8-21

3^#

發表於 2012-4-3 21:53 | 只看該作者

進階篩選確實可以得到不重複的資料~~感謝!!!
另外(D欄如果有資料, 紅字標示 ,插入下一欄位,並複製其B/D/G/H/I欄位的資料)
分解動作為
1.Sheet2中的D12(D欄如果有資料),D13插入新列,
2.D12移動到C13的位置
3.複製B12/D12/G12/H12/I12的資料至B13/D13/G13/H13/I13
4.其餘D欄如果有資料~依此類推

TOP

register313

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

4^#

發表於 2012-4-3 23:16 | 只看該作者

回復 3# marklos

Sheet1 A : J 欄的第一列要先加上資料的欄位名稱

Sub EX()
Sheet3.Cells.Clear
Sheet1.UsedRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet3.Range("A1"), Unique:=True
With Sheet3
For R = .[D2].End(xlDown).Row To 2 Step -1
If .Cells(R, "D") <> "" Then
.Rows(R + 1).EntireRow.Insert
.Cells(R + 1, "B").Resize(1, 9).Value = .Cells(R, "B").Resize(1, 9).Value
.Cells(R + 1, "C") = .Cells(R, "D")
End If
Next R
.[D2:D65536] = ""
End With
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 100
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-4-25

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

5^#

發表於 2012-4-4 09:48 | 只看該作者

回復 3# marklos

Sub ex()
Dim ar()
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each a In .Range(.[A1], .[A1].End(xlDown))
x = Join(Application.Transpose(Application.Transpose(a.Resize(, 10).Value)), Chr(9))
If IsEmpty(d(x)) Then
d(x) = x
y = Split(x, Chr(9))
If a.Offset(, 3) <> "" Then
For i = 1 To 2
If i = 2 Then y(0) = ""
ReDim Preserve ar(s)
ar(s) = y
s = s + 1
Next
Else
ReDim Preserve ar(s): ar(s) = y: s = s + 1
End If
End If
Next
End With
With Sheets("Sheet3")
Application.DisplayAlerts = False
.[A1].Resize(s, 10) = Application.Transpose(Application.Transpose(ar))
Application.DisplayAlerts = True
End With
End Su