Thursday, September 3, 2015

Autofilter Automation inbetween two Dates

Dim myArray(3) As String, lookuprng As Range
Public rowcount As Long, wb As Workbook
Public sheetname As String, newrowcount As Long, datarng As Range, tempval As Integer
Private Sub CommandButton1_Click()
''On Error Resume Next
tempval = 0
    For j = 0 To 3
   
    sheetname = Format(CDate(TextBox1.Value), "mmm") & "'" & Format(CDate(TextBox1.Value), "yy")
   
    rowcount = ThisWorkbook.Sheets(sheetname).Range("B" & Rows.Count).End(xlUp).Row
    Set lookuprng = ThisWorkbook.Sheets(sheetname).Range("A:A").Find(myArray(j), LookIn:=xlValues)
   
        If lookuprng Is Nothing Then
            ThisWorkbook.Sheets(sheetname).Range("A" & rowcount + 3) = myArray(j)
            ThisWorkbook.Sheets(sheetname).Range("B" & rowcount + 3) = TextBox1.Value & "-" & TextBox2.Value
            ThisWorkbook.Sheets(sheetname).Range("A" & (rowcount + 3) & ":B" & (rowcount + 3)).Font.Bold = True
        Exit For
        End If
    Next
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\Onsite Report.xlsx")
    newrowcount = wb.Sheets(sheetname).Range("B" & Rows.Count).End(xlUp).Row
    i = 0
    wb.Sheets(sheetname).AutoFilterMode = False
    wb.Sheets(sheetname).Range("A1:T1").AutoFilter field:=3, Criteria1:=">=" & TextBox1.Value, Operator:=xlAnd, Criteria2:="<=" & TextBox2.Value
   
    Set datarng = wb.Sheets(sheetname).Range("B4:B" & newrowcount).SpecialCells(xlCellTypeVisible)
    For Each cell In datarng
        i = i + 1
        ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 5 + i)) = cell
        ThisWorkbook.Sheets(sheetname).Range("C" & (rowcount + 5 + i)) = cell.Offset(0, 7)
        ThisWorkbook.Sheets(sheetname).Range("D" & (rowcount + 5 + i)) = cell.Offset(0, 10)
        ThisWorkbook.Sheets(sheetname).Range("E" & (rowcount + 5 + i)) = cell.Offset(0, 15)
        ThisWorkbook.Sheets(sheetname).Range("F" & (rowcount + 5 + i)) = cell.Offset(0, 6)
        ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 5 + i)) = cell.Offset(0, 4)
         tempval = tempval + CInt(ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 5 + i)))
    Next
    ThisWorkbook.Sheets(sheetname).Range("G" & (rowcount + 6 + i)) = tempval
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With ThisWorkbook.Sheets(sheetname).Range("B" & (rowcount + 6) & ":G" & (rowcount + 5 + i)).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.DisplayAlerts = False
    wb.Close
    Unload Me
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
'Application.ScreenUpdating = False
TextBox1.Value = Format(Date, "d-mmm-yy")
TextBox2.Value = Format(Date, "d-mmm-yy")

myArray(0) = "Week 1"
myArray(1) = "Week 2"
myArray(2) = "Week 3"
myArray(3) = "Week 4"

End Sub

Download File

No comments:

Post a Comment