VBA Filter Names from List One by One and then Copy filtered data

[Sufiyan97]

I have a data like below

I a VBA to Filter Names from List (J16:J20) One by One and then Copy the filtered data:

Book1
	C	D	E	F	G	H	I	J	K	L
1		Name	Amount
2		A	5
3		A	5
4		B	10
5		B	10
6		C	15
7		C	15
8		D	20
9		D	20
10		E	25
11		E	25
12
13		Total Quantity	150
14		Total Amount	4500
15
16								A
17								B
18								C
19								D
20								E
21
22
23
24
25
Sheet1

Cell Formulas
Range	Formula
E13	E13	=SUBTOTAL(9,E2:E11)
E14	E14	=E13*30

 

[Anthony47]

Hii

Getting below error

I forgot to mention that the new code still rely on Function SetClipBoardText

One another thing can you please update, current filter is based on exact match, it is case sensitive, can we make it case unsensitive??
and for example in excel inbuilt filter when we search in filter "John", then we will get all the results for "John" like, "John wick Other text", "Other Text John Wick" etc.
Can we modify the code so that it can search everything based on value in column J like excel inbuilt filter?

The following penultimate version filters using the "Contain" method of Excel filter and is case insensitive:

Sub SeqToClip_V3()
Dim fRange As Range, kArea As Range
Dim fArr As String, I As Long, cFilt, J As Long
'
Set fRange = Range(Range("D1"), Range("D1").End(xlDown).Offset(0, 1))   'Assuming the table starts in D1
'
For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fArr = ""
    For J = 1 To fRange.Rows.Count
''        If fRange.Cells(J, 1).Value = cFilt Then
        If InStr(1, fRange.Cells(J, 1).Value, cFilt, vbTextCompare) > 0 Then
            fArr = fArr & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf
        End If
    Next J
    DoEvents
'
    If Len(fArr) > 2 Then
        fArr = fArr & fRange.Cells(J + 1, 1).Value & " - " & fRange.Cells(J + 1, 2).Value & vbCrLf
        fArr = fArr & fRange.Cells(J + 2, 1).Value & " - " & fRange.Cells(J + 2, 2).Value & vbCrLf
        SetClipBoardText (fArr)   'fRange.Cells(2, 1).Resize(fRange.Rows.Count - 2, 2).SpecialCells(xlCellTypeVisible).Value)
        Beep
        MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
    End If
'
Next I
MsgBox ("Completed")
End Sub


Function SetClipBoardText(ByVal Text As Variant) As Boolean
    SetClipBoardText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text)
End Function

It already include the code for Function SetClipBoardText

Of course, with that approach, when you filter for John will also get Johnson (just to mention one of the many possible situations)

 

[Sufiyan97]

Hi Anthony,
It works, but does not consider subtotal, it gives total value from the bottom of entire data and not a subtotal for filtered data:

Name - Amount
A - 5
A - 5
Total Quantity - 150
Total Amount - 4500

 

[Anthony47]

Grrrrr...

This code seem to do the job:

Sub SeqToClip_V4()
Dim fRange As Range, kArea As Range
Dim fArr As String, I As Long, cFilt, J As Long
'
Set fRange = Range(Range("D1"), Range("D1").End(xlDown).Offset(0, 1))   'Assuming the table starts in D1
'
For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fRange.AutoFilter Field:=1, Criteria1:="*" & cFilt & "*"
    fArr = ""
    For J = 1 To fRange.Rows.Count
''        If fRange.Cells(J, 1).Value = cFilt Then
        If InStr(1, fRange.Cells(J, 1).Value, cFilt, vbTextCompare) > 0 Then
            fArr = fArr & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf
        End If
    Next J
    DoEvents
'
    If Len(fArr) > 2 Then
        fArr = fArr & fRange.Cells(J + 1, 1).Value & " - " & fRange.Cells(J + 1, 2).Value & vbCrLf
        fArr = fArr & fRange.Cells(J + 2, 1).Value & " - " & fRange.Cells(J + 2, 2).Value & vbCrLf
        SetClipBoardText (fArr)   'fRange.Cells(2, 1).Resize(fRange.Rows.Count - 2, 2).SpecialCells(xlCellTypeVisible).Value)
        Beep
        MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
    End If
'
Next I
    fRange.AutoFilter Field:=1

MsgBox ("Completed")
End Sub


Function SetClipBoardText(ByVal Text As Variant) As Boolean
    SetClipBoardText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text)
End Function

 

[Sufiyan97]

Hi Anthony,

This is working perfectly.

And this is the final....

Can you please add one more thing if the data is like below how to include column C as well or can you please tell me which line to modify to include more columns to copy:

Book3
	B	C	D	E	F
1		Date	Name	Amount
2		28-09-2022	A	5
3		28-09-2022	A	5
4		29-09-2022	B	10
5		29-09-2022	B	10
6		30-09-2022	C	15
7		30-09-2022	C	15
8		01-10-2022	D	20
9		01-10-2022	D	20
10		02-10-2022	E	25
11		02-10-2022	E	25
12
13			Total Quantity	150
14			Total Amount	4500
15
16
Sheet1

Cell Formulas
Range	Formula
C4,C10	C4	=C3+1
E13	E13	=SUBTOTAL(9,E2:E11)
E14	E14	=E13*30

 

[Anthony47]

If you wish to add columns to the table then you have to work on the line fArr = fArr & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf

In the given code, fRange.Cells(J, 1) refers to column D and fRange.Cells(J, 2) to column E; to refer to column C you may well use fRange.Cells(J, 0); thus the line could become

fArr = fArr & fRange.Cells(J, 0).Value & " - " & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf

However, if column C is a date you need to format its content or you will see a number; thus:

fArr = fArr & Format(fRange.Cells(J, 0).Value, "dd-mmm-yyyy") & " - " & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf

 

[Sufiyan97]

Hi Anthony

Thank you very much for your time and great help, this is finally what I wanted.

Your support was great in modifying code again and again.

The final code which is working:

Sub SeqToClip_V4()
Dim fRange As Range, kArea As Range
Dim fArr As String, I As Long, cFilt, J As Long
'
Set fRange = Range(Range("D1"), Range("D1").End(xlDown).Offset(0, 1))   'Assuming the table starts in D1
'
For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fRange.AutoFilter Field:=1, Criteria1:="*" & cFilt & "*"
    fArr = ""
    For J = 1 To fRange.Rows.Count
''        If fRange.Cells(J, 1).Value = cFilt Then
        If InStr(1, fRange.Cells(J, 1).Value, cFilt, vbTextCompare) > 0 Then
            fArr = fArr & fRange.Cells(J, 0).Value & " - " & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf
        End If
    Next J
    DoEvents
'
    If Len(fArr) > 2 Then
        fArr = fArr & fRange.Cells(J + 1, 1).Value & " - " & fRange.Cells(J + 1, 2).Value & vbCrLf
        fArr = fArr & fRange.Cells(J + 2, 1).Value & " - " & fRange.Cells(J + 2, 2).Value & vbCrLf
        SetClipBoardText (fArr)   'fRange.Cells(2, 1).Resize(fRange.Rows.Count - 2, 2).SpecialCells(xlCellTypeVisible).Value)
        Beep
        MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
    End If
'
Next I
    fRange.AutoFilter Field:=1

MsgBox ("Completed")
End Sub


Function SetClipBoardText(ByVal Text As Variant) As Boolean
    SetClipBoardText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text)
End Function

 

[Sufiyan97]

I have one more question:

What is the difference between the general copy with Ctrl + C and the copying with the code above?

Because when I manually copy the data with Ctrl + C

and paste it to WhatsApp chat, it pastes as image like below

And when I run the code and paste it, it past as values as below:

 

[Anthony47]

A) The macro read the value from the cell and put it into a string (fArr); then the string is pushed into the windows clipboard (Function SetClipBoardText); that clipboard is then available to external applications (the WhatsApp page, in your case).
B) Contr-c copy the range into the office clipboard; you have several options when pasting the information within Excel or other Office applications, but when you operate through external graphic applications you get an image of the range with its content
In shots: A and B do different things

 

[Sufiyan97]

Ok thanks for the explanation.

Can we make our code to work for option B
I mean just like Ctrl + C

 

[Anthony47]

Copying as image would be even simpler; for example:

Sub SeqToClip_Pict()
Dim fRange As Range, fRC As Long
Dim I As Long, cFilt
'
Set fRange = Range(Range("D1"), Range("D1").End(xlDown).Offset(0, 1))   'Assuming the table starts in D1
fRC = fRange.Rows.Count
'
For I = 16 To 1000
    cFilt = Cells(I, "J").Value
    If Len(cFilt) = 0 Then Exit For
    fRange.AutoFilter Field:=1, Criteria1:="*" & cFilt & "*"
    If fRange.SpecialCells(xlCellTypeVisible).Count > 2 Then             'See message 1
        Range(fRange.Cells(1, 0), fRange.Cells(fRC + 3, fRange.Columns.Count)).Copy     'See message 2
        Beep
        MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
    End If
Next I
fRange.AutoFilter Field:=1
Application.CutCopyMode = False
MsgBox ("Completed")
End Sub

Notes:
1) The macro (as well the ones I suggested before) will not output a message if there are no filtered rows; if this is a problem then you need to remove the If fRange.SpecialCells(xlCellTypeVisible).Count > 2 Then /End If lines (2 lines)
2) The code, as uses fRange.Cells(1, 0) for the starting cell, already includes column C in the copy

Try...