Код VBA для сопоставления строкового шаблона в столбце на листе Excel - PullRequest
Новая
       13

Код VBA для сопоставления строкового шаблона в столбце на листе Excel

1 голос
/ 17 февраля 2012

Пожалуйста, опубликуйте код VBA.

Мы получим отчет в формате Excel, состоящий из 17 столбцов, и я хочу вынуть элементы после сопоставления строкового шаблона в столбце 'K' на листе 1.

Ниже приведен образец предметов из колонки 'K'

героиня
я герой, я ноль, я виллан
герой
виллан
героиня
я геройЯ ноль, я виллан
виллан, героиня
герой, виллан
актер
ноль
я герой, я ноль

Теперь у меня естьприменил фильтр к столбцу 'K' и затем-> текстовый фильтр-> содержит-> затем данный шаблон * hero * zero * (который выбирает все строки, содержащие hero & zero).

Ниже записан макрос для вышеуказанного действия. 

Sub Macro1()  
'  
' Macro1 Macro  
'  

'
    Columns("H:H").Select  
    Selection.AutoFilter  
    ActiveSheet.Range("$H$1:$H$12").AutoFilter Field:=1, Criteria1:= _  
        "=****hero*zero****", Operator:=xlAnd  
End Sub

А теперь полученный результат (в столбце 'K' того же листа (sheet1))

Я герой, я ноль, я виллан
Я герой, я ноль, я виллан
Я герой, я ноль

Я хочу VBAкод для выполнения вышеуказанного действия, и я хочу, чтобы приведенный выше результат (он должен содержать 17 столбцов, которые находятся на листе 1) в листе 2.
Пожалуйста, помогите мне по вышеуказанному.
Заранее спасибо.

Ответы [ 2 ]

4 голосов
/ 17 февраля 2012

neobee, теперь ваш вопрос имеет больше смысла:)

Попробуйте следующее.

ПРОВЕРЕНО И ИСПЫТАНО 

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim LastRowWs As Long
    Dim Rng As Range

    '~~> Set your Input Sheet
    Set ws = Sheets("Sheet1")

    '~~> Get the lastrow in Sheet1
    LastRowWs = ws.Cells.Find(What:="*", After:=ws.Range("A1"), _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    '~~> Filter the Range
    ws.Range("A1:K" & LastRowWs).AutoFilter Field:=11, Criteria1:= _
    "=*hero*zero*", Operator:=xlAnd

    With ws.AutoFilter.Range
        On Error Resume Next
        '~~> Set the copy range [17 to include all 17 columns]
        Set Rng = .Offset(1, 0).Resize(.Rows.Count - 1, 17) _
                   .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With

    '~~> There is no match found
    If Rng Is Nothing Then
        MsgBox "There is no data which matches the '*hero*zero*' criteria"
        Exit Sub
    End If

    '~~> Prepare sheet 2 for output
    Sheets("Sheet2").Cells.Clear

    '~~> Copy the cells
    Rng.Copy Sheets("Sheet2").Range("A1")

    '~~> Remove autofilter from Input sheet
    ws.AutoFilterMode = False
End Sub
1 голос
/ 17 февраля 2012

Я не могу отладить код прямо сейчас, но что-то вроде этого должно сделать: 

Sub filter_and_copy()   
    Sheets("Sheet1").Range("K1").AutoFilter Field:=1, Criteria1:= _  
        "=*hero*zero*", Operator:=xlAnd 
    Sheets("Sheet1").Range("A:R").SpecialCells(xlvisible).Copy Destination:= _
        Sheets("Sheet2").Range("A1")
End Sub
...