patternModerate
Avoiding repeated code in worksheet
Viewed 0 times
codeavoidingrepeatedworksheet
Problem
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
```
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)
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)
Solution
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
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:
Then you want to select all these rows and copy them to a new worksheet that you name after the "currency name":
Notice I'm using the
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:
Now this might be made cleaner if you defined and used constants instead of magic strings:
Couple points
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 FunctionThen 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 SubNotice 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
XXXXXandEnd XXXXXshould 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
Withblocks 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.
Code Snippets
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 FunctionPrivate 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 SubSet 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"Const EURUSD As String = "EURUSD"
Const GBPUSD As String = "GBPUSD"
...Context
StackExchange Code Review Q#35844, answer score: 18
Revisions (0)
No revisions yet.