Avoiding repeated code in worksheet

Question

Can someone help me make this code more professional? I'm trying my best to find something similar, but I wasn't successful.

I want to avoid the repeat of the code for every single value and also I can't find a solution to avoid select. I only get it run when I repeat the code and count rng, rng1, rng2 etc.

Sub a()
 Dim cell As Range, i As Integer, wks As Worksheet
 Dim rng As Range
 Dim rng1 As Range
 Dim rng2 As Range
 Dim rng3 As Range
 Set Bereich = Sheets("Tabelle1").Range("B2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
 For Each cell In Bereich
 If cell.Value = "EURUSD" Then
 If Not rng Is Nothing Then
 Set rng = Union(rng, Rows(cell.Row))
 Else
 Set rng = Rows(cell.Row)
 End If
 End If
 Next cell
 rng.EntireRow.Select
 With Selection
 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
 Sheets(ActiveSheet.Name).Name = "EURUSD"
 rng.EntireRow.Copy Worksheets("EURUSD").Cells(5, 1)
 End With
'--------------------------------------------------------------------------------
 Sheets("Tabelle1").Select
 For Each cell In Bereich
 If cell.Value = "GBPUSD" Then
 If Not rng1 Is Nothing Then
 Set rng1 = Union(rng1, Rows(cell.Row))
 Else
 Set rng1 = Rows(cell.Row)
 End If
 End If
 Next cell
 rng1.EntireRow.Select
 With Selection
 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
 Sheets(ActiveSheet.Name).Name = "GBPUSD"
 rng1.EntireRow.Copy Worksheets("GBPUSD").Cells(5, 1)
 End With
'--------------------------------------------------------------------------------
 Sheets("Tabelle1").Select
 For Each cell In Bereich
 If cell.Value = "AUDUSD" Then
 If Not rng2 Is Nothing Then
 Set rng2 = Union(rng2, Rows(cell.Row))
 Else
 Set rng2 = Rows(cell.Row)
 End If
 End If
 Next cell
 rng1.EntireRow.Select
 With Selection
 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
 Sheets(ActiveSheet.Name).Name = "AUDUSD"
 rng2.EntireRow.Copy Worksheets("AUDUSD").Cells(5, 1)
 End With
'--------------------------------------------------------------------------------
 Sheets("Tabelle1").Select
 For Each cell In Bereich
 If cell.Value = "NZDUSD" Then
 If Not rng3 Is Nothing Then
 Set rng3 = Union(rng3, Rows(cell.Row))
 Else
 Set rng3 = Rows(cell.Row)
 End If
 End If
 Next cell
 rng1.EntireRow.Select
 With Selection
 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
 Sheets(ActiveSheet.Name).Name = "NZDUSD"
 rng3.EntireRow.Copy Worksheets("NZDUSD").Cells(5, 1)
 End With
End Sub

• Malachi: sounds like you need to create a function or two.

Answer 1

Doing Copy+Paste in your IDE should raise a big red flag and then there should be a neural inhibitor that prevents your left hand from doing it, causing your right hand to move your mouse further down the module and then start typing Private Function...

Now the first thing you need to do before you write any code, is "What is it exactly that I need to be doing?" - don't think in terms of "well I need to loop all cells in that range and check if its value matches a certain specific string, then I need to do [xyz]"; rather, think at one or two levels of abstraction above that, like "well I need to copy all the rows with the same currency code to a new worksheet that's named after the currency code in question".

If I understand what you're doing, you could consider starting with something like this:

Private Function GetRowsForCurrency(ByVal SourceRange As Range, ByVal CurrencyName As String) As Range
 Dim Cell As Range
 Dim Result As New Range
 For Each Cell In SourceRange
 If Cell.Value = CurrencyName Then Set Result = Union(Result, Rows(Cell.Row))
 Next
 Set GetRowsForCurrency = Result
End Function

Then you want to select all these rows and copy them to a new worksheet that you name after the "currency name":

Private Sub CopyToNewWorksheet(ByVal SourceRange As Range, ByVal CurrencyName As String)
 Dim Result As Worksheet
 Set Result = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
 Result.Name = CurrencyName
 SourceRange.EntireRow.Copy Result.Cells(5, 1) 'comment why (5,1) here
End Sub

Notice I'm using the Add function's return value, which represents the sheet that was added.

With a function to get the cells and a procedure to copy them to a new sheet, all that's left to do is to call them:

Set Bereich = Sheets("Tabelle1").Range("B2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
CopyToNewWorksheet GetRowsForCurrency(Bereich, "EURUSD"), "EURUSD"
CopyToNewWorksheet GetRowsForCurrency(Bereich, "GBPUSD"), "GBPUSD"
CopyToNewWorksheet GetRowsForCurrency(Bereich, "AUDUSD"), "AUDUSD"
CopyToNewWorksheet GetRowsForCurrency(Bereich, "NZDUSD"), "NZDUSD"

Now this might be made cleaner if you defined and used constants instead of magic strings:

Const EURUSD As String = "EURUSD"
Const GBPUSD As String = "GBPUSD"
...

---

Couple points

• NEVER call a procedure a() - give it a meaningful name that starts with a verb and that says what the code does. If you can't easily give it a name, it's probably doing too many things.
• Indent your code properly: anything between XXXXX and End XXXXX should be 1 Tab further to the right. If your code starts to look like arrow code , you've got a code smell (follow that link!).
• Those With blocks are absolutely useless - you're never using your with block variable, which means you've set an object reference for no reason.
• If you feel the need to add a number at the end of a variable name, stop right there, take your hands off the keyboard and study what your code is doing that's redundant - refactor as needed.

• user3016646: That would be nice. I am just beginning (3 Weeks) with programming VBA in Excel and read as much as I could to help my self, but here is the point where my knowledge is much overstressed. I will take a look if I can find something to start with Procedure and function. Take the time you need, I am glad that there is someone out there who is willing to help me out and is spending his freetime to explain me what to do and where to look for more information Regards, Adam
• Mathieu Guindon: @user3016646 Edited; feel free to mark your question as accepted, we're on a mission to get this beta site into a full-fledged graduated StackExchange site that will be the place to come for peer reviews :)
• Mathieu Guindon: @user3016646 Take the time you need, I am glad that there is someone out there who is willing to help me out and is spending his freetime to explain me what to do and where to look for more information - just so you know, reading this made my day and totally makes up for much less positive feedback this site got today.
• user3016646: That was a quick response, thank you very much. Now I have to study the Basics over private functions and private sub. Because I want to understand it, so that I know what I am doing. At least I hope so -:) Also must I look what to do with your answer, wich button to puch and what else, but I will find that somewhere on this site. I will give you a feedback when I got it to work. Regards, Adam
• Mathieu Guindon: Functions return a value and procedures (/"subs*) just run. If you declare them in a code module, you can call a function from a cell function (which is utterly cool), and a procedure can be called as a "macro" /assigned to a button that the user can click to execute.

Answer 2

A couple of things that @Mat's Mug didn't mention.

1. Use Option Explicit

   You set Betreich equal to a range, but the variable isn't declared anywhere. You'll nip a lot of runtime errors in the bud if you let the compiler catch the lack of variable declaration.

2. Avoid Select and Activate

   Again, we're looking to avoid runtime errors, but there is a style issue here as well. You use worksheet and range objects elsewhere in your code. Why not here? Be consistent.

   rng.EntireRow.Select
   With Selection
   ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
   Sheets(ActiveSheet.Name).Name = "EURUSD"
   rng.EntireRow.Copy Worksheets("EURUSD").Cells(5, 1)
   End With
   

   Which brings me to..

3. Properly indent your code.

   Ok, so it was already mentioned, but it's a biggie for readability.