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

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 A4:PXXX, 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

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("A1:P1").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("A1:P1"), _
Unique:=False

End Sub

--
Regards,
Tom Ogilvy



"markx" <[email protected]> wrote in message
news:%[email protected]...
> 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 A4:PXXX, 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
>
>