Macro adjustment

[Khalil Handal]

Hi,

I have this code for a macro, develped with the help of Dave Peterson
(thanks to him again). I need to adjust so as to:



1- I have 2 wokbooks with 15 sheets in each of them, 12
sheets have the same name in each workbook. I want the macro to verify the
sheet name that it is run from in the first work book (HCP_2005) and copy
the filtered rows to the second workbook WV_2005 to the same sheetname, i.e.
if the macro is run from the sheet "January 2005" in workbook "HCP_2005"
then the copying will be done to the workbook "WV_2005" in the sheet with
the same name "January 2005". The 2 workbooks are in the same folder.

2- Is it possibe to check if the macro is run twice it will
replace the lines that are copied the first time. (when executing the macro
it starts copying at the cell A7 since the first 6 rows are used). I need it
to start at cell A7.

3- I want it to copy cells D1 and D2 to the second sheet in
the same location D1 and D2.



The code is as follows:



Sub Macro1()



Dim RngToFilter As Range

Dim RngToCopy As Range

Dim DestWks As Worksheet

Dim DestCell As Range

Dim LastRow As Long



With ActiveSheet

.Unprotect Password:="1230"

'turn off any existing filter

.AutoFilterMode = False

Set RngToFilter = .Range("ei16", .Cells(.Rows.Count,
"EI").End(xlUp))

RngToFilter.AutoFilter Field:=1, Criteria1:="<>"

If RngToFilter.Cells.SpecialCells(xlCellTypeVisible).Count = 1 Then

'no visible rows in filter.

Set RngToCopy = Nothing

Else

With RngToFilter

Set RngToCopy = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _

.Cells.SpecialCells(xlCellTypeVisible)

End With

End If

.AutoFilterMode = False

.Protect Password:="1230"

End With



If RngToCopy Is Nothing Then

MsgBox "Nothing filtered--quitting"

Exit Sub

End If



Set DestWks = Nothing

On Error Resume Next

Set DestWks = Workbooks("wv_05.xls").Worksheets("October 2005")

On Error GoTo 0

If DestWks Is Nothing Then

Set DestWks = Workbooks.Open(ThisWorkbook.Path &
"\WV_05.xls").Worksheets("October 2005")

End If



With DestWks

LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1

Set DestCell = .Cells(LastRow, "A")

End With



RngToCopy.EntireRow.Copy _

Destination:=DestCell



Application.CutCopyMode = False



End Sub





I will apritiate any help.

Khalil Handal

 

[Dave Peterson]

#2: The way that I would approach it is to apply the filter and then find out
how many rows are shown. Then look for a group of cells that match a key column
(column A?). If the keys match, then do the copy.

I'll leave that to you to attempt.

#1 and #3: This compiled, but I didn't set up the test workbooks to test it:

Option Explicit
Sub testme01()

Dim RngToFilter As Range
Dim RngToCopy As Range
Dim DestWks As Worksheet
Dim DestCell As Range
Dim LastRow As Long
Dim fWkbk As Workbook
Dim tWkbk As Workbook
Dim wks As Worksheet

'make sure both workbooks are open!
Set fWkbk = Workbooks("HCP_2005.xls")
Set tWkbk = Workbooks("WV_2005.xls")

For Each wks In fWkbk.Worksheets
Set DestWks = Nothing
On Error Resume Next
Set DestWks = tWkbk.Worksheets(wks.Name)
On Error GoTo 0

If DestWks Is Nothing Then
'no match, do nothing
Else
With wks
.Unprotect Password:="1230"
'turn off any existing filter
.AutoFilterMode = False
Set RngToFilter = .Range("ei16", _
.Cells(.Rows.Count, "EI").End(xlUp))
RngToFilter.AutoFilter Field:=1, Criteria1:="<>"
If RngToFilter.Cells _
.SpecialCells(xlCellTypeVisible).Count = 1 Then
'no visible rows in filter.
Set RngToCopy = Nothing
Else
With RngToFilter
Set RngToCopy _
= .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
End With
End If
.AutoFilterMode = False
.Protect Password:="1230"
End With

If RngToCopy Is Nothing Then
MsgBox "Nothing filtered on: " & wks.Name
Else
With DestWks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
Set DestCell = .Cells(LastRow, "A")
End With
RngToCopy.EntireRow.Copy _
Destination:=DestCell
End If
DestWks.Range("D1:d2").Value = .Range("d1:d2").Value
End If
Next wks
Application.CutCopyMode = False
End Sub