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

marklos

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

下載 (125.9 KB)

2012-4-3 19:16

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

下載 (73.39 KB)

2012-4-3 19:27

結果 Sheet3

下載 (94.06 KB)

2012-4-3 19:24

感謝幫忙

GBKEE

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

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

複製代碼

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

marklos

進階篩選確實可以得到不重複的資料~~感謝!!!
另外(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欄如果有資料~依此類推

register313

回復 3# marklos

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

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

複製代碼

Hsieh

回復 3# marklos

1. Sub ex()
   
2. Dim ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets("Sheet1")
   
5. For Each a In .Range(.[A1], .[A1].End(xlDown))
   
6. x = Join(Application.Transpose(Application.Transpose(a.Resize(, 10).Value)), Chr(9))
   
7. If IsEmpty(d(x)) Then
   
8.   d(x) = x
   
9. y = Split(x, Chr(9))
   
10. If a.Offset(, 3) <> "" Then
    
11. For i = 1 To 2
    
12. If i = 2 Then y(0) = ""
    
13.   ReDim Preserve ar(s)
    
14.   ar(s) = y
    
15.   s = s + 1
    
16. Next
    
17. Else
    
18. ReDim Preserve ar(s): ar(s) = y: s = s + 1
    
19. End If
    
20. End If
    
21. Next
    
22. End With
    
23. With Sheets("Sheet3")
    
24. Application.DisplayAlerts = False
    
25. .[A1].Resize(s, 10) = Application.Transpose(Application.Transpose(ar))
    
26. Application.DisplayAlerts = True
    
27. End With
    
28. End Su

複製代碼

marklos

如果只是單純將Sheet2 變成Sheet3 那應該如何?
單純將D欄的資料剪接到下一列的C欄位 , 並將原本的那一列的部份儲存格資料複製到下一列C欄位~

register313

回復 6# marklos

1. Sub EX()
   
2. Sheet3.Cells.Clear
   
3. X = 1
   
4. With Sheet2
   
5.   For R = 1 To .[A65536].End(xlUp).Row
   
6.     .Range("A" & R & ":J" & R).Copy Sheet3.Range("A" & X)
   
7.     X = X + 1
   
8.     If .Range("D" & R) <> "" Then
   
9.        .Range("A" & R & ":J" & R).Copy Sheet3.Range("A" & X)
   
10.        Sheet3.Range("D" & X - 1).Copy Sheet3.Range("C" & X)
    
11.        X = X + 1
    
12.     End If
    
13.   Next R
    
14. End With
    
15. Sheet3.[D2:D65536] = ""
    
16. End Sub

複製代碼