Efficient Code

R

Rubber Beaked Woodpecker

Board Regular
Joined
Aug 30, 2015
Messages
205
Office Version
  1. 2021
Any kind sole able to give advice on how to make my code run more efficiently? :cautious:

I'm guessing that I have too many range events and these could maybe merged into one event?

Thanks
RBW


VBA Code: 
Option Explicit

Dim currentMarket As String
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Columns.Count = 16 Then
    Application.EnableEvents = False 'Turn off events so changes to cell don't retrigger event
    Range("Q1").Value = WorksheetFunction.CountIf(Range("H5:H50"), ">0") ' this counts cells above zero
    Range("Q2") = Range("W2")
     Range("U1") = Range("U2")
      Range("T1") = Range("T2")
       Range("AA1") = Range("Z1")
                      If Range("S1") = 1 Then
                      
          Call ThisSheetlogBalance
          Call logEvent
          Call logBalance
          Call logNumbers
          Call logPrice
          Call logHighest
          
                           ElseIf Range("X2").Value = "Yes" Then
             Call R1
                                    
        End If
   End If
   
   Application.EnableEvents = True 'Turn on events again
End Sub

Sub logBalance()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet8")

source.Range("Z5:Z16").Copy

emptyColumn = destination.Cells(31, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("A28")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(31, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
End If

   
End Sub
Sub logPrice()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet8")

source.Range("Y5:Y16").Copy

emptyColumn = destination.Cells(44, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("A43")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(44, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
End If

   
End Sub


Sub logHighest()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet8")

source.Range("T1:T1").Copy

emptyColumn = destination.Cells(30, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("A28")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(30, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
End If

   
End Sub
Sub ThisSheetlogBalance()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet1")

source.Range("Z5:Z16").Copy

emptyColumn = destination.Cells(5, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("AA5")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(5, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
End If

   
End Sub

Sub logEvent()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet8")

source.Range("A1:A1").Copy

emptyColumn = destination.Cells(29, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("A28")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(29, emptyColumn).PasteSpecial Transpose:=False
    Application.CutCopyMode = False
    
End If

   
End Sub
Sub logNumbers()
   
Dim source As Worksheet
Dim destination As Worksheet
Dim emptyColumn As Long

Set source = Sheets("Sheet1")
Set destination = Sheets("Sheet8")

source.Range("U1:U1").Copy

emptyColumn = destination.Cells(28, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range("A28")) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
       
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(28, emptyColumn).PasteSpecial Transpose:=False
    Application.CutCopyMode = False
    
End If

   
End Sub

Sub R1()
'
' R1 Macro
'

'
    Sheets("Sheet1").Select
    Range("R1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
               Range("T1").Select
         
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
Does this help?
VBA Code: 
Option Explicit

Dim currentMarket As String
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Columns.Count = 16 Then
    Application.EnableEvents = False 'Turn off events so changes to cell don't retrigger event
    Range("Q1").Value = WorksheetFunction.CountIf(Range("H5:H50"), ">0") ' this counts cells above zero

    Application.Calculation = xlCalculationManual
    Range("Q2").Value = Range("W2").Value
    Range("U1").Value = Range("U2").Value
    Range("T1").Value = Range("T2").Value
    Range("AA1").Value = Range("Z1").Value
    Application.Calculation = xlCalculationAutomatic

    If Range("S1").Value = 1 Then
        Call Log_("BalanceOfThisSheet")
        Call Log_("Event")
        Call Log_("Balance")
        Call Log_("Numbers")
        Call Log_("Price")
        Call Log_("Highest")
    ElseIf Range("X2").Value = "Yes" Then
        Call R1
    End If
End If
 
Application.EnableEvents = True 'Turn on events again

End Sub

Sub Log_(property As String)

Dim source As Worksheet, destination As Worksheet
If UCase(property) = "BALANCEOFTHISSHEET" Then
    Set source = Sheets("Sheet1")
    Set destination = Sheets("Sheet1")
Else
    Set source = Sheets("Sheet1")
    Set destination = Sheets("Sheet8")
End If

Dim copyRangeAddress As String, destinationRangeAddress As String, destinationRow As Long
Select Case UCase(property)
    Case "BALANCE"
        copyRangeAddress = "Z5:Z16"
        destinationRangeAddress = "A28"
        destinationRow = 31

    Case "PRICE"
        copyRangeAddress = "Y5:Y16"
        destinationRangeAddress = "A43"
        destinationRow = 44

    Case "HIGHEST"
        copyRangeAddress = "T1:T1"
        destinationRangeAddress = "A28"
        destinationRow = 30

    Case "BALANCEOFTHISSHEET"
        copyRangeAddress = "Z5:Z16"
        destinationRangeAddress = "AA5"
        destinationRow = 5

    Case "EVENT"
        copyRangeAddress = "A1:A1"
        destinationRangeAddress = "A28"
        destinationRow = 29

    Case "NUMBERS"
        copyRangeAddress = "U1:U1"
        destinationRangeAddress = "A28"
        destinationRow = 28

    Case Else
        MsgBox "This subroutine doesn't exist", vbCritical, "Failed"
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        End
End Select

source.Range(copyRangeAddress).Copy

Dim emptyColumn As Integer
emptyColumn = destination.Cells(destinationRow, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range(destinationRangeAddress)) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(destinationRow, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

End Sub

Sub R1()
    Sheets("Sheet1").Range("R2").Value = Sheets("Sheet1").Range("R1").Value
    Application.EnableEvents = False
    Range("T1").Select
    Application.EnableEvents = True
End Sub
 
Last edited:
Upvote 0
Oh, and I missed it, but the end of the Log_ function, instead of the last lines being:
VBA Code: 
source.Range(copyRangeAddress).Copy

Dim emptyColumn As Integer
emptyColumn = destination.Cells(destinationRow, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range(destinationRangeAddress)) Then
    destination.Cells(1, 1).PasteSpecial Transpose:=True
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(destinationRow, emptyColumn).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

they should be:
VBA Code: 
Dim emptyColumn As Integer
emptyColumn = destination.Cells(destinationRow, destination.Columns.Count).End(xlToLeft).Column

If IsEmpty(destination.Range(destinationRangeAddress)) Then
    source.Range(copyRangeAddress).Copy
    destination.Cells(1, 1).PasteSpecial Transpose:=True
Else
    emptyColumn = emptyColumn + 1
    destination.Cells(destinationRow, emptyColumn).Value = source.Range(copyRangeAddress).Value
End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
More Efficient Code
Replies
3
Views
411
Rubber Beaked Woodpecker
R
R
  • Question Question
Merge two pieces of code
Replies
1
Views
314
Rubber Beaked Woodpecker
R
R
  • Question Question
paste to the next available row
Replies
1
Views
597
Trebor76
T
R
  • Solved
Add Additional Code
Replies
2
Views
397
Rubber Beaked Woodpecker
R
R
  • Solved
Macro to run every 5 seconds until manual stopped
Replies
7
Views
514
Logit
Logit

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top