how to Filter particular / specific word and cut & paste in different sheet by vba

[m_vishal_c]

HI, i need to filter particular / specific word in particular column like("A column") and select all(Filtered data), cut and paste , create another sheet in same workbook and paste into it.

for example
Need to filter "MPS" in code column and move those filtered in another sheet by creating new sheet

code	address	Part
PIT-000000013000835326	1	1
TAP-000000012502567470	1	1
2FRE-65-00-MPS-020	1	1
ALF-00000001250258666	1	1
ALF-000000012502612937	1	1
2FRE-65-00-MPS-031|2FRE-65	1	1
ALF-000000012502621977	1	1
TAP-00000001500557215	1	1

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

heaps thanks in advance

thanks

 

[RileyC]

Pseudo VBA code:

define variant 2d string array
for every row
if find mps in string > 0 then
add column number to array with the data
end if
add new sheet to workbook
for i to array size
for j to array(i) size
cells (i,j) value = sheet value array(i)(j)
next j
next i

Once I get home if this doesn't help I'll write the code for you but it'd be rather simple. If you have a huge amount of rows might need to fix this code slightly in order to allow for a faster run-time, or I would recommend using another language besides VBA to sort it.

 

[m_vishal_c]

Pseudo VBA code:

define variant 2d string array
for every row
if find mps in string > 0 then
add column number to array with the data
end if
add new sheet to workbook
for i to array size
for j to array(i) size
cells (i,j) value = sheet value array(i)(j)
next j
next i

Once I get home if this doesn't help I'll write the code for you but it'd be rather simple. If you have a huge amount of rows might need to fix this code slightly in order to allow for a faster run-time, or I would recommend using another language besides VBA to sort it.

Hi RileyC,
thanks for replying, i am new to macro so it will be great if you can provide me the code. i have to use vba because i am using excel to manipulate data

thanks


i have found some codes on internet and i changed as per my requirement please see below

[/COLOR]Application.ScreenUpdating = FalseDim x As Range
Dim rng, rng1 As Range
Dim last As Long
Dim sht As String


'specify sheet name in which the data is stored
sht = "Sheet1"


'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:F" & last)
Set rng1 = Worksheets("Need to be removed MPS").Range("B2")




For Each x In rng1 'Range(Sheets("Need to be removed 0").B2)   '([L2], Cells(Rows.Count, "L").End(xlUp)) ' K column has some specific value in excel so macro will create only those value's extra sheet
With rng
.AutoFilter
.AutoFilter Field:=1, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy


Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x


' Turn off filter
Sheets(sht).AutoFilterMode = False


With Application
.CutCopyMode = False
.ScreenUpdating = True

End With
[COLOR=#574123]

thanks

 

[Logit]

.
Here is one method :

Option Explicit




Sub FilterCopyPaste()
    Dim strLastRow As String
    Dim rngC As Range
    Dim ws As Worksheet
    Dim strToFind As String, FirstAddress As String
    Dim wSht As Worksheet
    Dim rngtest As String
    Dim i As Integer
    Application.ScreenUpdating = False
    
    Set wSht = Worksheets("Sheet2")
    strToFind = InputBox("Enter Search Term")
    
    On Error Resume Next


    If SheetExist(strToFind) Then
        MsgBox "The sheet name   " & strToFind & "   already exists" & vbCrLf & _
        "Please delete the sheet   " & strToFind & "   and try again." & vbCrLf & _
        "Cancelling process.", vbCritical, "Cancelling Request"
        Exit Sub
    End If
    
    With ActiveSheet.Range("A2:Z30000")
        Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                Set ws = ThisWorkbook.Sheets.Add(After:= _
                         ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    ws.Name = strToFind
                    ws.Range("A1").Value = "Code"
                    ws.Range("B1").Value = "Address"
                    ws.Range("C1").Value = "Part"
                    ws.Range("A1").ColumnWidth = 30
                    ws.Range("B1").ColumnWidth = 10
                    ws.Range("C1").ColumnWidth = 10
                Do
                    strLastRow = Sheets(Sheets.Count).Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy Destination:=ActiveSheet.Cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With
    
    MsgBox "Process Complete !", vbInformation, "Process Complete"
End Sub




Function SheetExist(strSheetName As String) As Boolean
    Dim i As Integer


    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = strSheetName Then
            SheetExist = True
            Exit Function
        End If
    Next i
End Function

Download workbook : https://www.amazon.com/clouddrive/share/fbthhk0BCQ5mkS7KUwQ2MXpvJwtw4XMwXu9zmvXq9nJ

 

[m_vishal_c]

.
Here is one method :

Option Explicit




Sub FilterCopyPaste()
    Dim strLastRow As String
    Dim rngC As Range
    Dim ws As Worksheet
    Dim strToFind As String, FirstAddress As String
    Dim wSht As Worksheet
    Dim rngtest As String
    Dim i As Integer
    Application.ScreenUpdating = False
    
    Set wSht = Worksheets("Sheet2")
    strToFind = InputBox("Enter Search Term")
    
    On Error Resume Next


    If SheetExist(strToFind) Then
        MsgBox "The sheet name   " & strToFind & "   already exists" & vbCrLf & _
        "Please delete the sheet   " & strToFind & "   and try again." & vbCrLf & _
        "Cancelling process.", vbCritical, "Cancelling Request"
        Exit Sub
    End If
    
    With ActiveSheet.Range("A2:Z30000")
        Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
            If Not rngC Is Nothing Then
                FirstAddress = rngC.Address
                Set ws = ThisWorkbook.Sheets.Add(After:= _
                         ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    ws.Name = strToFind
                    ws.Range("A1").Value = "Code"
                    ws.Range("B1").Value = "Address"
                    ws.Range("C1").Value = "Part"
                    ws.Range("A1").ColumnWidth = 30
                    ws.Range("B1").ColumnWidth = 10
                    ws.Range("C1").ColumnWidth = 10
                Do
                    strLastRow = Sheets(Sheets.Count).Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy Destination:=ActiveSheet.Cells(strLastRow, 1)
                    Set rngC = .FindNext(rngC)
                Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
            End If
    End With
    
    MsgBox "Process Complete !", vbInformation, "Process Complete"
End Sub




Function SheetExist(strSheetName As String) As Boolean
    Dim i As Integer


    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = strSheetName Then
            SheetExist = True
            Exit Function
        End If
    Next i
End Function

Download workbook : https://www.amazon.com/clouddrive/share/fbthhk0BCQ5mkS7KUwQ2MXpvJwtw4XMwXu9zmvXq9nJ

heaps thanks for this code.

(1) i do have a large data when i run this code it ask me "Msg box" which data need to be filtered. but it shows other data too.
(2) after copy and creating new sheet, i need to remove those data from Sheet1 and create new workbook on same name(Filtered name)


Please guide me, much appreciate your help

thanks

 

[m_vishal_c]

heaps thanks for this code.

(1) i do have a large data when i run this code it ask me "Msg box" which data need to be filtered. but it shows other data too.
(2) after copy and creating new sheet, i need to remove those data from Sheet1 and create new workbook on same name(Filtered name)


Please guide me, much appreciate your help

thanks

and another thing, that dialog box check entire sheet. there are changes that "MPS" word contains many columns. i need to run only particular column so it wont give wrong calculation.
If you want then i can send you file. please let me know

thanks