Snasui Excel Forum

Code: Select all

Function SJ(f As Range, c As Range) As String
Dim a, l As Long, wb As Workbook, j As String, Ap As Application
Application.ScreenUpdating = False
    Set Ap = CreateObject("Excel.Application")
    Set wb = Ap.Workbooks.Open(Filename:=f.Value, ReadOnly:=True)
    With wb.Sheets(1)
        l = .Cells(Rows.Count, 1).End(xlUp)
        a = .Evaluate(Replace("Transpose(IF(MMULT(N(ISNUMBER(SEARCH(""" & c & """,B8:AY#))),TRANSPOSE(COLUMN(B1:AY1)^0)),A8:$A#))", "#", l))
    End With
    wb.Close
    a = Filter(a, False, False)
    For l = 0 To UBound(a)
        j = j & "," & Application.Text(a(l), "d-mmm-yy;;")
    Next
    SJ = Mid(j, 2)
Application.ScreenUpdating = True
End Function

Code: Select all

Function SearchContact_Func_join(f As Range, c As Range) As String
    Dim s As String, a() As Variant, b As Variant
    Dim xlApp As Application, wb As Workbook
    Dim i As Long, j As Long, k As Long
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    With Worksheets("Sheet1")
        s = LCase(c.Value)
        Set wb = xlApp.Workbooks.Open(Filename:=f.Value, ReadOnly:=True)
    End With
    j = 0
    With wb.Sheets(1)
        .Range("a3").CurrentRegion.EntireRow.Hidden = False
        b = .Range("a8", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 51)
        For i = 1 To UBound(b)
            For k = 1 To 51
                If InStr(LCase(b(i, k)), s) Then
                    ReDim Preserve a(j)
                    a(j) = b(i, 1)
                    j = j + 1
                    Exit For
                End If
            Next k
        Next i
    End With
    wb.Close False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    SearchContact_Func_join = VBA.Join(a, ",")
End Function

Code: Select all

'
'
'
Dim fs As Variant
Dim nb As Integer
    fs = Application.Transpose(a)
    nb = Application.CountA(fs)

    
    SearchContact_Func = nb
'
'
'

Code: Select all

    If Dir(fp & ".xlsx") = "" Then
        MsgBox "File not found": Exit Sub

Code: Select all

Sub Search()
Application.ScreenUpdating = False
Dim s As String, fp As String, r As Range, a, n As Long, wb As Workbook, l As Long
fp = Range("B1").Value
s = LCase(Range("b2").Value)
    If Dir(fp & ".xlsx") = "" Then
        MsgBox "File not found": Exit Sub
    Else
        Set wb = Workbooks.Open(fp & ".xlsx", ReadOnly:=True)
        l = wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        ReDim a(l)
        For Each r In wb.Sheets(1).Range("a8:a" & l)
            a(n) = Join(Application.Transpose(Application.Transpose(r.Resize(, 51))), "^")
            n = n + 1
        Next
        wb.Close
        a = Filter(a, s)
        If UBound(a) = -1 Then
            MsgBox "No data": Exit Sub
        Else
            With [A5].Resize(UBound(a) + 1)
                .Value = Application.Transpose(a)
                .TextToColumns Destination:=Range("A5"), DataType:=xlDelimited, Other:=True, _
                OtherChar:="^", FieldInfo:=Evaluate("choose({1,2},row(1:51),1)")
            End With
        End If
    End If
Application.ScreenUpdating = True
End Sub

Code: Select all

Sub openbook()
Dim wb As Workbook
On Error GoTo err1
        Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)
err1:
        MsgBox "ไม่พบไฟล์ที่ค้นหา", vbCritical
        Exit Sub

End Sub

Code: Select all

& ".xlsx"

Code: Select all

If........then
MsgBox "ไม่มีข้อมุล" & ID, vbCritical
else
Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)
End If

Code: Select all

Set wb = Workbooks.Open(Filename:=.Range("B1").Value, ReadOnly:=True)