Macro simplifying - copy rows to worksheets based on values in 2 different columns

[markx]

Hello everybody,



I know this is a big piece, but I don't know how to separate it into several
smaller problems... Sorry if it's too huge for one time :-(



I "inherited" a workbook with 25 different macros that, once they are ran
together, they easily take half an hour. As far as I can see, the macros
were just "recorded", there was even no "screenupdating = false" line... I
tried to optimize it by myself (even if I'm still just a beginner in VBA)
but I suppose - once again - that it's too hard for my current level.




Below (=at the end of this message), you'll find the "original" code, just
for one country ("Austria"), the codes for other countries follow exactly
the same scheme... As you can see, the goal here is to use an "advanced
filter" with criteria (select rows from the "AP_Detail" sheet) where EITHER
in column "A" OR in column "P" we have the desired value = "AT") then copy
the filtered range to the "Austria" sheet. Then do the same for all other
units...




Seems conceptually simple, but how to represent this through a "clean" VBA
(i.e. not "recording" the VBA step by step)? Do we need a special "filter"
table to do this, or is it possible to use something like:

- for all the values on the active sheet (perhaps they could even be
specified as an array {"AT","BE","CH","FR"} within the VBA code?) make
filtering with OR criteria (either the picked value is present in A column
OR in P column)

- then copy the filtered range to the newly created sheets (these could be
also named {"AT","BE","CH","FR"}, I suppose this is much easier than taking
some other names)



======================



BTW: I don't know if this can help, but I have also (in my "collection") a
VBA that makes half of this job, copying rows to sheets, based on the value
in the column "A". I paste it here.



Sub CopyRowsToSheets()

'copy rows to worksheets based on value in column A

'assume the worksheet name to paste to is the value in Col A

Dim CurrentCell As Range

Dim SourceRow As Range

Dim Targetsht As Worksheet

Dim TargetRow As Long

Dim CurrentCellValue As String



'start with cell A2 on "Master" sheet

Set CurrentCell = Worksheets("Master").Cells(2, 1) 'row ... column ...



Do While Not IsEmpty(CurrentCell)

CurrentCellValue = CurrentCell.Value

Set SourceRow = CurrentCell.EntireRow



'Check if worksheet exists

On Error Resume Next

Testwksht = Worksheets(CurrentCellValue).Name

If Err.Number = 0 Then

'MsgBox CurrentCellValue & " worksheet Exists"

Else

MsgBox "Adding a new worksheet for " & CurrentCellValue

Worksheets.Add.Name = CurrentCellValue

End If



On Error GoTo 0 'reset on error to trap errors again



Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)



' Find next blank row in Targetsht - check using Column A

TargetRow = Targetsht.Cells(Rows.Count, 1).End(xlUp).Row + 1

SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)



'do the next cell

Set CurrentCell = CurrentCell.Offset(1, 0)

Loop

End Sub



* * *



Below, you can find the code I try to simplify (as said before, this is just
a sample regarding one "unit", there are in fact 25 codes like this one,
executed one after another L ):


(range "area" refers to A4XXX, and range "AT_CR" is just representing OR
criteria for filtering (cells on a separate worksheet))



''''''''''''''''''''''''''''''''''''''''

"original" code

''''''''''''''''''''''''''''''''''''''''

Sub Austria()
Sheets("AP_Detail").Select
Rows("3:3").Select
Selection.AutoFilter
Sheets("Filters").Select
Range("A6").Select
ActiveCell.FormulaR1C1 = "AT"

Sheets("Austria").Select
Rows("4:4").Select
Selection.AutoFilter
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp

Range("A4").Select
Sheets("AP_Detail").Select
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("area").AdvancedFilter Action:=xlFilterInPlace,
CriteriaRange:=Range( _
"AT_CR"), Unique:=False
Selection.Copy
Sheets("Austria").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.AutoFilter
ActiveWindow.SmallScroll ToRight:=4
Selection.AutoFilter Field:=16, Criteria1:="<>0", Operator:=xlAnd
Selection.Sort Key1:=Range("O5"), Order1:=xlAscending, Key2:=Range("G5")
_
, Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A4").Select
End Sub



* * *



Thank you very much in advance for any hint or advice you could have
regarding this problem...

Have a nice week,

Mark

 

[Tom Ogilvy]

If you want to copy all rows from a sheet ("AP_Detail") that have the value
AT in column A or P

Sub ABC()
Dim rng As Range
With Worksheets("AP_Detail")
.Columns("R:S").ClearContents
.Range("A11").Copy Destination:= _
Worksheets("Austria").Range("A1")
Set rng = .Range("A1").CurrentRegion.Resize(, 16)
' set up OR criteria in R1:S3 of AP_Detail
.Range("R1").Value = Range("A1").Value
.Range("S1").Value = Range("P1").Value
.Range("R2").Value = "AT"
.Range("S3").Value = "AT"
.Range("R1:S3").Name = "Criteria"
End With
' copy the data with advanced filter
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Criteria"), _
CopyToRange:=Worksheets("Austria").Range("A11"), _
Unique:=False

End Sub