รบกวนขอสูตรแยก ข้อมูลที่ duplicate ตามเงือนไขของจำนวนคู่

[akekorn]

สวัสดีครั้บเพื่อนสมาชิกทุกท่าน
วันนี้ผมมีปัญหาอยากขอความรู้เรื่องสูตรการจัดการกลุ่มข้อมูล duplicate ตามจำนวนคู่ กล่าวคือหากผมมีข้อมูล
ผมต้องการจัดการข้อมูลให้เหลือจำนวนข้อมูลหาร 2 เหลือเท่าไหร่ให้ remove duplicate ให้เหลือตามยอดที่หารได้ตามตัวอย่าง
A1A1A1A1A1A1
A1A1A1A1A1A1
A1A1A1A1A1A1
A1A1A1A1A1A1
A1A1A1A1A1A1
A1A1A1A1A1A1
B2B2B2B2
B2B2B2B2
B2B2B2B2
B2B2B2B2

จากตัวอย่างข้อมูลชุดแรก มีจำนวนซ้ำ 6 ครั้ง เมื่อหาร 2 จะได้ 6
ผมต้องการให้แสดงเพียง
A1A1A1A1A1A1
A1A1A1A1A1A1
A1A1A1A1A1A1

และตัวอย่างที่2 มีข้อมูลจำนวนซ้ำ 4 ครั้่งเมื่อหาร 2 จะได้ 2
ผมต้องการให้แสดงเพียง
B2B2B2B2
B2B2B2B2


โดยผมได้แนบตัวอย่างมาด้วยต้องขอความอนุเคราะห์เพื่อนสมาชิกด้วยครับผม
ขอบคุณครับ

[puriwutpokin]

ที่ D1=IF(--(COUNTIF(A$1:A1,A1)>COUNTIF(A$1:A$36,A1)/2)=0,A1,"")

[akekorn]

พอดีลองเขียน vba ดู แต่มันไม่ลบตามเงื่อนไขที่ต้องการครับ โดยผมได้แนบ file มาด้วย

Code: Select all

Sub DeleteTheDoops()
Dim RowNdx As Long
Dim RowNdx2 As Long
Dim FR As Long
FR = Range("A1:A1").End(xlDown).Row 'Freeze this row
For RowNdx = FR To 2 Step -1
    For RowNdx2 = FR To 2 Step -1
        'From what I can tell, you are interested when A, E and F are
        'equal and when C is smallest, so ...
        If RowNdx <> RowNdx2 And _
           Cells(RowNdx, "A").Value = Cells(RowNdx2, "A").Value Then
               Rows(RowNdx2).Delete
        End If
    Next RowNdx2
Next RowNdx
End Sub

รบกวนเพื่อนสมาชิกช่วยผมด้วยครับ
ขอบคุณครับ

[akekorn]

ขอบคุณ คุณpuriwutpokin มากๆครับ แต่ถ้าผมอยากเขียน เป็น VBA จะเขียน อย่างไรดีครับ เพราะเวลาใช้งานจริง ข้อมูลเป็นหลักแสน รบกวนแนะนำว่า VBAที่ผมทำต้องปรับแก้อะไรดีถึงจะได้คำตอบที่ต้องการครับ
ขอบคุณครับ

[puriwutpokin]

ลองปรับโค้ดตามนี้ดูครับ

Code: Select all

Sub KeepDuplicateHaft()
Dim rAll As Range
Dim i, N As Integer
Set rAll = Range("A1:A36")
N = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = True
For i = 1 To N
If (Application.CountIf(Range("A1:A" & i), Cells(i, "A")) > Application.CountIf(rAll, Cells(i, "A")) / 2) = 0 Then
Cells(i, "A") = Cells(i, "A")
Else
Cells(i, "A") = ""
End If
Next i
rAll.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

[akekorn]

ขอบพระคุณมากๆครับผม

[Bo_ry]

อีกแบบ

Code: Select all

Sub RemoveHalf()
On Error Resume Next
Dim R As Range

For Each R In Range("a1").CurrentRegion
If R = R.Offset(1) And R.Offset(-1, 3) = "" Then R.Offset(0, 3) = R
Next
Range("a1").CurrentRegion.Offset(0, 3).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub