Below I have attached some VBA which Summarizes the data below. What i am trying to do is to have the ability to enter a date or a date range which then the code uses to report. So if I entered a date range of 26/07/210 - 02/08/2010 the code would report on these data ranges, is this something easy to do?
Thanks in advance for any help
[face=Courier New]Sub Count_Slot_Items()
Dim LastRow As Long
Application.ScreenUpdating = False
With Sheets("Sheet2")
.Columns("A:L").Clear
For c = 0 To 10 Step 2
Sheets("Sheet1").Columns("B:B").Offset(, c / 2).Copy Destination:=.Range("B1").Offset(, c)
.Columns("B:B").Offset(, c).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1").Offset(, c), Unique:=True
.Columns("B:B").Offset(, c).Clear
LastRow = .Range("A" & Rows.Count).Offset(, c).End(xlUp).Row
.Range("B1").Offset(, c).Value = "Count"
If LastRow > 1 Then
.Range("B2").Offset(, c).Formula = "=COUNTIF(Sheet1!" & Columns(2 + c / 2).Address & "," & Range("A2").Offset(, c).Address(0, 0) & ")"
If LastRow > 2 Then
.Range("B2").Offset(, c).AutoFill Destination:=.Range("B2:B" & LastRow).Offset(, c)
End If
.Range("B2:B" & LastRow).Offset(, c).Value = .Range("B2:B" & LastRow).Offset(, c).Value
End If
Next c
' Format cells
Range("A1").Copy
Range("A1", Range("A1").End(xlToRight)).PasteSpecial Paste:=xlPasteFormats
.Select
End With
Application.ScreenUpdating = True
End Sub
[/face]
Thanks in advance for any help
Excel Workbook | |||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | |||
1 | Venues Code | Slot 1 | Slot 2 | Slot 3 | Slot 4 | Slot 5 | Slot 6 | Slot 1 | Slot 2 | Slot 3 | Slot 4 | Slot 5 | Slot 6 | ||
2 | Date | 26/07/2010 | 02/08/2010 | ||||||||||||
3 | 56878 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
4 | 56879 | 277 | 708 | 222 | 444 | 277 | 708 | 222 | 444 | ||||||
5 | 56880 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
6 | 56881 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
7 | 56882 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
8 | 56883 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
9 | 56884 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
10 | 56885 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
11 | 56886 | 277 | 708 | 444 | 277 | 708 | 444 | ||||||||
12 | 56887 | 588 | 708 | 444 | 588 | 708 | 444 | ||||||||
13 | 56888 | 588 | 708 | 222 | 444 | 588 | 708 | 222 | 444 | ||||||
14 | 56889 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
15 | 56890 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
16 | 56891 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
17 | 56892 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
18 | 56893 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
19 | 56894 | 588 | 708 | 5555 | 588 | 708 | 5555 | ||||||||
20 | 56895 | 111 | 708 | 222 | 5555 | 111 | 708 | 222 | 5555 | ||||||
21 | 56896 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
22 | 56897 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
23 | 56898 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
24 | 56899 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
25 | 56900 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
26 | 56901 | 111 | 708 | 5555 | 111 | 708 | 5555 | ||||||||
Sheet1 |
[face=Courier New]Sub Count_Slot_Items()
Dim LastRow As Long
Application.ScreenUpdating = False
With Sheets("Sheet2")
.Columns("A:L").Clear
For c = 0 To 10 Step 2
Sheets("Sheet1").Columns("B:B").Offset(, c / 2).Copy Destination:=.Range("B1").Offset(, c)
.Columns("B:B").Offset(, c).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1").Offset(, c), Unique:=True
.Columns("B:B").Offset(, c).Clear
LastRow = .Range("A" & Rows.Count).Offset(, c).End(xlUp).Row
.Range("B1").Offset(, c).Value = "Count"
If LastRow > 1 Then
.Range("B2").Offset(, c).Formula = "=COUNTIF(Sheet1!" & Columns(2 + c / 2).Address & "," & Range("A2").Offset(, c).Address(0, 0) & ")"
If LastRow > 2 Then
.Range("B2").Offset(, c).AutoFill Destination:=.Range("B2:B" & LastRow).Offset(, c)
End If
.Range("B2:B" & LastRow).Offset(, c).Value = .Range("B2:B" & LastRow).Offset(, c).Value
End If
Next c
' Format cells
Range("A1").Copy
Range("A1", Range("A1").End(xlToRight)).PasteSpecial Paste:=xlPasteFormats
.Select
End With
Application.ScreenUpdating = True
End Sub
[/face]