Tidy up macro!
 

I have a macro which is made up of seven macros which do almost exactly the
same thing. The only thing that differs each time is the cell that is
copied and the destination of the filtered information. A2 is copied into
D1 on sheet2 and column D is then filtered and if any data is found it is
copied to A5 on sheet1.

This process is repeated 7 times for dates in A2:G2

What I would like to do is simplify the process by not having the same code
used 7 times. Is this possible?

I have enclosed one of the macros so that you can see how it is done.

Sub Checkdate1()
If Not IsEmpty(Worksheets("Sheet1").Range("A2").Value) Then
Worksheets("Sheet2").Range("D1").Value =
Worksheets("Sheet1").Range("A2").Value
Range("B1").AutoFilter Field:=4, Criteria1:="=6"
Set rng = ActiveSheet.AutoFilter.Range
Set rng1 = Intersect(rng, Columns(2)).SpecialCells(xlVisible)
If rng1.Count <= 1 Then
Selection.AutoFilter Field:=4
Exit Sub
End If
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count)
Set rng = Intersect(rng, Range("C:C"))
rng.Copy Worksheets("Sheet1").Range("A5")
Selection.AutoFilter Field:=4
End If
End Sub

Tidy up macro!
 

I don't understand a bit about what you're doing (see below), but
this will cycle A2:G2:

Public Sub CheckDates()
Dim cell As Range
Dim d1Cell As Range
Dim rng As Range

With Worksheets("Sheet2")
Set d1Cell = .Range("D1")
For Each cell In Worksheets("Sheet1").Range("A2:G2")
If Not IsEmpty(cell.Value) Then
d1Cell.Value = cell.Value
.Range("B1").AutoFilter _
field:=4, Criteria1:="=6"
Set rng = .AutoFilter.Range
If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then _
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)
.Range("B1").AutoFilter field:=4
End If
Next cell
End With
End Sub

Things I don't understand:

1) Why you copy the value from Sheet1!A2 to Sheet2!D1 and then don't
use it anywhere.

2) Your Criteria1 is fixed, rather than dependent on Sheet1!A2 - is
that right (if it is, it will return the same data each time)? If it
should be dependent on Sheet1!A2, then replace

Criteria1:="=6"

with

Criteria1:="=" & cell.Value

3) Why you're a) filtering on column D, b) checking for visible
cells in column B, and c) Copying column C.

Note that by using Columns(2) for your Intersect().SpecialCells,
you'll get an error if there are no visible cells in column B

Note also that the returned values will start in the first row that
meets Criteria1. If the data is not sorted on column 4, the returned
values will include data that is not visible in the autofilter.


In article ,
"Gareth" wrote:

I have a macro which is made up of seven macros which do almost exactly the
same thing. The only thing that differs each time is the cell that is
copied and the destination of the filtered information. A2 is copied into
D1 on sheet2 and column D is then filtered and if any data is found it is
copied to A5 on sheet1.

This process is repeated 7 times for dates in A2:G2

What I would like to do is simplify the process by not having the same code
used 7 times. Is this possible?

I have enclosed one of the macros so that you can see how it is done.

Sub Checkdate1()
If Not IsEmpty(Worksheets("Sheet1").Range("A2").Value) Then
Worksheets("Sheet2").Range("D1").Value =
Worksheets("Sheet1").Range("A2").Value
Range("B1").AutoFilter Field:=4, Criteria1:="=6"
Set rng = ActiveSheet.AutoFilter.Range
Set rng1 = Intersect(rng, Columns(2)).SpecialCells(xlVisible)
If rng1.Count <= 1 Then
Selection.AutoFilter Field:=4
Exit Sub
End If
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count)
Set rng = Intersect(rng, Range("C:C"))
rng.Copy Worksheets("Sheet1").Range("A5")
Selection.AutoFilter Field:=4
End If
End Sub

Tidy up macro!
 

One way:

Replace

If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then _
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)


with


If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)
cell.Offset(1, 0).Value = Application.CountA( _
cell.Offset(3, 0).Resize(65532, 1))
End If

In article ,
"Gareth" wrote:

Thanks very much for this, it does exactly what I want it to. Apologies if
I didn't explain everything but it would appear you understood my main aim.

I have forgotten one bit, after the copy and paste onto sheet1 I want to
count the number of records and put it into cell.Offset(1,0)

Hope you can help.

Gareth
"J.E. McGimpsey" wrote in message
...
I don't understand a bit about what you're doing (see below), but
this will cycle A2:G2:

Public Sub CheckDates()
Dim cell As Range
Dim d1Cell As Range
Dim rng As Range

With Worksheets("Sheet2")
Set d1Cell = .Range("D1")
For Each cell In Worksheets("Sheet1").Range("A2:G2")
If Not IsEmpty(cell.Value) Then
d1Cell.Value = cell.Value
.Range("B1").AutoFilter _
field:=4, Criteria1:="=6"
Set rng = .AutoFilter.Range
If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then _
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)
IN HERE
.Range("B1").AutoFilter field:=4
End If
Next cell
End With
End Sub

Tidy up macro!
 

many thanks.

"J.E. McGimpsey" wrote in message
...
One way:

Replace

If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then _
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)


with


If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)
cell.Offset(1, 0).Value = Application.CountA( _
cell.Offset(3, 0).Resize(65532, 1))
End If

In article ,
"Gareth" wrote:

Thanks very much for this, it does exactly what I want it to. Apologies
if
I didn't explain everything but it would appear you understood my main
aim.

I have forgotten one bit, after the copy and paste onto sheet1 I want to
count the number of records and put it into cell.Offset(1,0)

Hope you can help.

Gareth
"J.E. McGimpsey" wrote in message
...
I don't understand a bit about what you're doing (see below), but
this will cycle A2:G2:

Public Sub CheckDates()
Dim cell As Range
Dim d1Cell As Range
Dim rng As Range

With Worksheets("Sheet2")
Set d1Cell = .Range("D1")
For Each cell In Worksheets("Sheet1").Range("A2:G2")
If Not IsEmpty(cell.Value) Then
d1Cell.Value = cell.Value
.Range("B1").AutoFilter _
field:=4, Criteria1:="=6"
Set rng = .AutoFilter.Range
If Intersect(rng, .Columns(2)).SpecialCells( _
xlCellTypeVisible).Count 1 Then _
Intersect(rng, .Range("C2:C65532")).Copy _
Destination:=cell.Offset(3, 0)
IN HERE
.Range("B1").AutoFilter field:=4
End If
Next cell
End With
End Sub