Snasui Excel Forum

Code: Select all

Dim iCount As Long, fstLine As Long
Dim strMatch As String, strCount As String
Dim shData As Worksheet, shResult As Worksheet
Set shData = Worksheets("data")
Set shResult = Worksheets("result")
With shResult
    strMatch = .Range("t3").Value & "*"
    strCount = "*" & .Range("t3").Value
End With
With shData
    fstLine = Application.Match(strMatch, .Range("c:c"), 0)
    iCount = Application.CountIf(.Range("c:c"), strCount)
    With shResult
       .Range("a3").Resize(.UsedRange.Rows.Count, 14).ClearContents
       .Range("a3").Resize(iCount, 14).Value = _
        shData.Range("a" & fstLine).Resize(iCount, 14).Value
    End With
End With

Code: Select all

strCount = "*" & .Range("t3").Value

Code: Select all

strCount = .Range("t3").Value & "*"

Code: Select all

    fstLine = Application.Match(strMatch, .Range("c:c"), 0)
    iCount = Application.CountIf(.Range("c:c"), strMatch)

Code: Select all

Sub Number()

On Error Resume Next
Dim iCount As Long, fstLine As Long
Dim strMatch As String, strCount As String
Dim shData As Worksheet, shResult As Worksheet
Set shData = Worksheets("data")
Set shResult = Worksheets("result")
With shResult
    strMatch = .Range("t3").Value & "*"
'    strCount = .Range("t3").Value & "*"
    strCount = "*" & .Range("t3").Value
End With
With shData
    fstLine = Application.Match(strMatch, .Range("c:c"), 0)
    iCount = Application.CountIf(.Range("c:c"), strMatch)
    With shResult
       .Range("a3").Resize(.UsedRange.Rows.Count, 14).ClearContents
       .Range("a3").Resize(iCount, 14).Value = _
        shData.Range("a" & fstLine).Resize(iCount, 14).Value
    End With
End With


With shResult
    strMatch = .Range("V3").Value & "*"
'    strCount = .Range("t3").Value & "*"
    strCount = "*" & .Range("v3").Value
End With
With shData
    fstLine = Application.Match(strMatch, .Range("c:c"), 0)
    iCount = Application.CountIf(.Range("c:c"), strMatch)
    With shResult
       '.Range("a3").Resize(.UsedRange.Rows.Count, 14).ClearContents
       .Range("a" & Range("c" & Rows.Count).End(xlUp).Row+1).Resize(iCount, 14).Value = _
        shData.Range("a" & fstLine).Resize(iCount, 14).Value
    End With
End With
End Sub

Code: Select all

Sub Number()
On Error Resume Next
Dim iCount As Long, fstLine As Long
Dim strMatch As String, strCount As String
Dim shData As Worksheet, shResult As Worksheet
Set shData = Worksheets("data")
Set shResult = Worksheets("result")
With shResult
    strMatch = .Range("t3").Value & "*"
    strCount = .Range("v3").Value & "*"
End With
With shData
    fstLine = Application.Match(strMatch, .Range("c:c"), 0)
    iCount = Application.Match(strCount, .Range("c:c"), 0) - 3 + Application.CountIf(.Range("c:c"), strCount)
    With shResult
       .Range("a3").Resize(.UsedRange.Rows.Count, 14).ClearContents
       .Range("a3").Resize(iCount, 14).Value = _
        shData.Range("a" & fstLine).Resize(iCount, 14).Value
    End With
End With
End Sub

Code: Select all

Dim rs As Range, cri As Range
Dim rt As Range
Dim rtBook As Workbook
Dim dbBook As Workbook
Set rtBook = ThisWorkbook
Dim i As Integer, j As Integer
Dim c1 As Integer, c2 As Integer
With rtBook.Worksheets("result")
    .Range("c2").CurrentRegion.ClearContents
    Set rt = .Range("a2")
    c1 = .Range("t3").Value
    c2 = .Range("v3").Value
End With
Set dbBook = Workbooks.Open(Filename:="C:\Users\Data.xlsx")
j = 1 'Criteria rows
With dbBook.Worksheets("sheet1")
    Set rs = .Range("a2", .Range("n" & .UsedRange.Rows.Count))
    .Range("q1").Value = "Acc"
    If c1 = 0 And c2 > 0 Then
        .Range("q2").Value = c2 & "*"
        j = j + 1
    ElseIf c1 > 0 And c2 = 0 Then
        .Range("q2").Value = c2 & "*"
        j = j + 1
    ElseIf c1 > 0 And c2 > 0 And c2 < c1 Then
        .Range("q2").Value = c1 & "*"
        .Range("q3").Value = c2 & "*"
        j = j + 2
    Else
        For i = 0 To c2 - c1
            .Range("q2").Offset(i, 0).Value = c1 + i & "*"
            j = j + i
        Next i
    End If
    Set cri = .Range("q1").Resize(j)
    rs.AdvancedFilter xlFilterCopy, cri, rt
    cri.ClearContents
End With