Finding 2 times and 3 times repeated value through VBA code support ?

[yugeshkumar]

Hi

in my excel data having column A
I want to extract the 2times and 3 times repeated value result to column B & C

check the value starts with "via at xy (xxxxx)" search in entire column A ,
in which 2 times repeated value copy to column B and 3 times repeated value copy to column c

result should be in with bracket (xxxxx) only, not come with via at xy

excel sheet

[kvsrinivasamurthy]

Show some . in the file

[yugeshkumar]

here attached excel sheet data2.xls, i have did manually through countif formula
I explain here, i m requesting the vba code to do same.

step1 using column A using begin with filter option filter out "via at xy copy to column B then removed text via at xy keeping (123456) only
step2 added countif formula find the repeated value 2/3/4
step3 filtered out column c extract the 2 and 3 times repeated value to column C then removed duplicate values.

using the above steps I'm doing manually, lot of sheet like this, to getting VBA code for the above process to simply my work.

[Vraag en antwoord]

Lots of the same questions.

https://www.excelforum.com/excel-pro...need-help.html

https://www.excelforum.com/excel-pro...que-value.html

Please respond to your other questions first.

[kvsrinivasamurthy]

Code for macro

Sub GetData()

Dim M1, M2, M3
Dim LR
LR = Range("A" & Rows.Count).End(xlUp).Row

M1 = Filter(Evaluate("Transpose(IF(ISnumber(Search(""VIA at xy"",A1:A" & LR & ")),TRIM(substitute(A1:A" & LR & ",""VIA at xy "","""")),False))"), False, False)

Range("B2:B" & UBound(M1) + 2) = WorksheetFunction.Transpose(M1)
[C2] = 1
[C3] = 2
Range("C2:C3").AutoFill Destination:=Range("C2:C" & UBound(M1) + 2)

    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & UBound(M1) + 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("B2:C" & UBound(M1) + 2)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

StRo = 1
For T = 2 To UBound(M1) + 2
If Range("B" & T + 1) <> Range("B" & T) Then
Range("D" & T) = T - StRo
StRo = T
End If
Next T

    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
        "C2:C" & UBound(M1) + 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("B2:D" & UBound(M1) + 2)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

M2 = Filter(Evaluate("Transpose(IF(D2:D" & UBound(M1) + 2 & "=2,B2:B" & UBound(M1) + 2 & ",False))"), False, False)

M3 = Filter(Evaluate("Transpose(IF(D2:D" & UBound(M1) + 3 & "=3,B2:B" & UBound(M1) + 2 & ",False))"), False, False)

Range("E2:E" & UBound(M2) + 2) = WorksheetFunction.Transpose(M2)
Range("F2:F" & UBound(M3) + 2) = WorksheetFunction.Transpose(M3)

Range("c2").EntireColumn.Delete
End Sub

[yugeshkumar]

Hi after running that above code getting error image attached please do the needful

Attachment 736899

[kvsrinivasamurthy]

Attachment not opening.

[yugeshkumar]

Attachment 736970

error on below line
ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
"B2:B" & UBound(M1) + 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal

[jindon]

Sub test()
    Dim a, x, i As Long, ii As Long, n As Long, flg As Boolean, col As Collection
    x = Filter([transpose(if(isnumber(search("    VIA at xy",a1:a10000)),mid(a1:a10000,16,len(a1:a10000)-17)))], False, 0)
    If UBound(x) = -1 Then Exit Sub
    Cells(1).CurrentRegion.Offset(, 1).ClearContents
    Set col = New Collection
    ReDim a(1 To UBound(x) + 1, 1 To 2)
    On Error Resume Next
    For i = 0 To UBound(x)
        Err.Clear: n = n + 1
        col.Add n, x(i)
        If Err = 0 Then
            a(n, 1) = x(i): a(n, 2) = 1
        Else
            a(col(x(i)), 2) = a(col(x(i)), 2) + 1: n = n - 1
        End If
    Next
    On Error GoTo 0
    For i = 2 To UBound(x) + 1
        flg = False
        For ii = 1 To n
            If a(ii, 2) = i Then
                If Not flg Then Cells(1, i) = i & "times repeated value": flg = True
                Cells(Rows.Count, i).End(xlUp)(2) = a(ii, 1)
            End If
        Next
    Next
End Sub

[yugeshkumar]

Result come with open and closing bracket its helpful

[yugeshkumar]

Sub test()
    Dim a, x, i As Long, ii As Long, n As Long, flg As Boolean, col As Collection
    x = Filter([transpose(if(isnumber(search("    VIA at xy",a1:a10000)),mid(a1:a10000,16,len(a1:a10000)-17)))], False, 0)
    If UBound(x) = -1 Then Exit Sub
    Cells(1).CurrentRegion.Offset(, 1).ClearContents
    Set col = New Collection
    ReDim a(1 To UBound(x) + 1, 1 To 2)
    On Error Resume Next
    For i = 0 To UBound(x)
        Err.Clear: n = n + 1
        col.Add n, x(i)
        If Err = 0 Then
            a(n, 1) = x(i): a(n, 2) = 1
        Else
            a(col(x(i)), 2) = a(col(x(i)), 2) + 1: n = n - 1
        End If
    Next
    On Error GoTo 0
    For i = 2 To UBound(x) + 1
        flg = False
        For ii = 1 To n
            If a(ii, 2) = i Then
                If Not flg Then Cells(1, i) = i & "times repeated value": flg = True
                Cells(Rows.Count, i).End(xlUp)(2) = a(ii, 1)
            End If
        Next
    Next
End Sub

Result come with open and closing bracket its helpful

[kvsrinivasamurthy]

Program running without any problem for Data2.xlsx . The code I have used is copied from thread.
.xlsx file is up loaded. Upload .xlsm file with code. The file in which you are facing problem.

[yugeshkumar]

i'm downloaded data2 ans.xlsm‎ that excel problem.

[kvsrinivasamurthy]

Where is the file.

[yugeshkumar]

Attachment 737204 from the above post of 06-14-2021, 07:09 PM