Posts by marav08

Sub Button40_Click()


Range("D10:D12,D15,D22,D25,D32:D33,D38:D42,D47:D50,D53,D55,D57,D63,G3").Select
Selection.Copy
Sheets("Sheet3").Select
'Range("I4").End(xlUp).Select
lMaxRows = Cells(Rows.Count, "I").End(xlUp).Row
Range("I" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True
Sheets("Sheet1").Select
Range("I4").Select
End Sub

Private Sub cmdFind_Click()


    Dim DateRange As Range, rCl As Range, rng As Range, Dn As Range
    Dim Date1 As Date, Date2 As Date
    Dim iX As Integer
    Dim strName As String
    Dim nrows As Long


    Set DateRange = Sheet2.Range("A1").CurrentRegion.Columns(4)
    Me.ListBox1.Clear
    strName = Me.txtName.Value
    Date1 = CDate(Me.txtDate.Value)
    Date2 = CDate(Me.EndDate.Value)
    For Each rCl In DateRange.Cells
    If (rCl.Value >= Date1 And rCl.Value <= Date2) And (rCl.Offset(0, -3).Value = strName) Then
      If rCl.Value = "" Then
            With Me.ListBox1
                .AddItem Sheet2.Cells(rCl.Row, 1)
                .List(.ListCount - 1, 1) = Sheet2.Cells(rCl.Row, 2)
                .List(.ListCount - 1, 2) = Sheet2.Cells(rCl.Row, 3)
                .List(.ListCount - 1, 3) = Sheet2.Cells(rCl.Row, 4)
                .List(.ListCount - 1, 4) = Sheet2.Cells(rCl.Row, 5)
                .List(.ListCount - 1, 5) = Format(Sheet2.Cells(rCl.Row, 6), "hh:mm:ss")
             End With
         End If
        End If
    Next rCl


End Sub


Private Sub EndDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)


    With Me.EndDate
    If Len(.Value) = 0 Then Exit Sub
        If Not IsDate(.Value) Then
            MsgBox "Please enter a correctly formatted date"
            .Value = Empty
            .SetFocus
        End If
        Exit Sub
    End With
End Sub


Private Sub txtDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With Me.txtDate
    If Len(.Value) = 0 Then Exit Sub
        If Not IsDate(.Value) Then
            MsgBox "Please enter a correctly formatted date"
            .Value = Empty
            .SetFocus
        End If
        Exit Sub
    End With
End Sub

Sub Button38_Click()
Dim newFileName As String, strPath As String
    Dim strFileName As String, strFileName1 As String, strDate As String, strExt As String, strFullname As String
    strPath = "\\10.80.2.4\Shared Folder$\Acurus Folder Redirection\virgilio.beltran\Desktop\New folder\"
    strFileName = Range("B4") 'Change to suit
    strFileName1 = Range("B6")
    strDate = Format(Date, "ddmmyyyy")
    strExt = ".xls" 'Change to suit
    strFullname = strFileName & strFileName1 & strDate
    newFileName = strFullname & "-" & GetNewSuffix(strPath, strFullname, strExt) & strExt
    MsgBox "The new FileName is: " & newFileName, vbOKCancel
     'Save copy
    ActiveWorkbook.SaveCopyAs strPath & newFileName
End Sub




Function GetNewSuffix(ByVal strPath As String, ByVal strFullname As String, ByVal strExt As String) As Integer
    Dim strFile As String, strSuffix As String, intMax As Integer
    On Error GoTo ErrorHandler
     'File's name
    strFile = Dir(strPath & "\" & strFullname & "*")
    Do While strFile <> ""
         'File's suffix starts 2 chars after 'root' name (right after the "-")
        strSuffix = Mid(strFile, Len(strFullname) + 2, Len(strFile) - Len(strFullname) - Len(strExt) - 1)
         'FileName is valid if 1st char after name is "-" and suffix is numeric with no dec point
         'Skip file if "." or "," exists in suffix
        If Mid(strFile, Len(strFullname) + 1, 1) = "-" And CSng(strSuffix) >= 0 And _
        InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
             'Store the max suffix
            If CInt(strSuffix) >= intMax Then intMax = CInt(strSuffix)
        End If
NextFile:
        strFile = Dir
    Loop
    GetNewSuffix = intMax + 1
    Exit Function


ErrorHandler:
    If Err Then
        Err.Clear
        Resume NextFile
    End If
End Function

Sub Button38_Click()
Dim newFileName As String, strPath As String
    Dim strFileName As String, strFileName1 As String, strDate As String, strExt As String
    strPath = "\\10.80.2.4\Shared Folder$\Acurus Folder Redirection\virgilio.beltran\Desktop\New folder\"
    strFileName = Range("B4") 'Change to suit
    strFileName1 = Range("B6")
    strDate = Format(Date, "ddmmyyyy")
    strExt = ".xls" 'Change to suit
    newFileName = strFileName & "-" & strFileName1 & "-" & strDate & "-" & GetNewSuffix(strPath, strFileName, strFileName1, strDate, strExt) & strExt
    MsgBox "The new FileName is: " & newFileName, vbOKCancel
     'Save copy
    ActiveWorkbook.SaveCopyAs strPath & newFileName
End Sub




Function GetNewSuffix(ByVal strPath As String, ByVal strName As String, ByVal strName1 As String, ByVal strDte As String, ByVal strExt As String) As Integer
    Dim strFile As String, strSuffix As String, intMax As Integer
    On Error GoTo ErrorHandler
     'File's name
    strFile = Dir(strPath & "\" & strName & "\" & strName1 & "\" & strDte & "*")
    Do While strFile <> ""
         'File's suffix starts 2 chars after 'root' name (right after the "-")
        strSuffix = Mid(strFile, Len(strName) + Len(strName1) + Len(strDte) + 2, Len(strFile) - Len(strName) - Len(strName1) - Len(strDte) - Len(strExt) - 1)
         'FileName is valid if 1st char after name is "-" and suffix is numeric with no dec point
         'Skip file if "." or "," exists in suffix
        If Mid(strFile, Len(strName) + Len(strName1) + Len(strDte) + 1, 1) = "-" And CSng(strSuffix) >= 0 And _
        InStr(1, strSuffix, ",") = 0 And InStr(1, strSuffix, ".") = 0 Then
             'Store the max suffix
            If CInt(strSuffix) >= intMax Then intMax = CInt(strSuffix)
        End If
NextFile:
        strFile = Dir
    Loop
    GetNewSuffix = intMax + 1
    Exit Function


ErrorHandler:
    If Err Then
        Err.Clear
        Resume NextFile
    End If
End Function

Sub Button38_Click()
Dim i As Long
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String
Dim nameDate As String
Dim fn As String
Dim check As String
Dim ok As Boolean


FileName1 = Range("B4")
FileName2 = Range("B6")
nameDate = Format(Date, "dd.mm.yyyy")
Path = "\\10.80.2.4\Shared Folder$\Acurus Folder Redirection\virgilio.beltran\Desktop\New folder"


fn = Path & FileName1 & "-" & FileName2 & "-" & nameDate & ".xlsm"
check = Dir(fn)
ok = (check = "")


Do Until ok
i = i + 1
fn = Path & FileName1 & "-" & FileName2 & "-" & nameDate & ".xlsm"
check = Dir(fn)
ok = (check = "")
Loop


ThisWorkbook.SaveAs fn






'ActiveWorkbook.SaveAs Filename:=Path & FileName1 & "-" & FileName2 & "-" & nameDate & ".xlsm", FileFormat:=xlNormal




End Sub

Private Sub cmdFind_Click()




    Dim DateRange As Range, rCl As Range, rng As Range, Dn As Range
    Dim Date1 As Date, Date2 As Date
    Dim iX As Integer
    Dim strName As String
    
    
    Set DateRange = Sheet2.Range("A1").CurrentRegion.Columns(4)
    Set rng = Sheet2.Range("A1").CurrentRegion.Columns(4)
    Me.ListBox1.Clear
    
    strName = Me.txtName.Text
    Date1 = CDate(Me.txtDate.Value)
    Date2 = CDate(Me.EndDate.Value)
   
    
    For Each rCl In DateRange.Cells
    For Each Dn In rng.Cells
        If rCl.Value >= Date1 And rCl.Value <= Date2 And strName Then
        ElseIf Dn.Value = strName Then
       
        
            With Me.ListBox1
                .AddItem Sheet2.Cells(rCl.Row, 1)
                .List(.ListCount - 1, 1) = Sheet2.Cells(rCl.Row, 2)
                .List(.ListCount - 1, 2) = Sheet2.Cells(rCl.Row, 3)
                .List(.ListCount - 1, 3) = Sheet2.Cells(rCl.Row, 4)
                .List(.ListCount - 1, 4) = Sheet2.Cells(rCl.Row, 5)
                .List(.ListCount - 1, 5) = Format(Sheet2.Cells(rCl.Row, 6), "hh:mm:ss")
            End With
        End If
    Next Dn
    Next rCl
End Sub