Tidy up macro!

  • Thread starter Thread starter Gareth
  • Start date Start date
G

Gareth

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
 
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.
 
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
 
many thanks.

J.E. McGimpsey said:
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
Click to expand...
 
Back
Top