Worksheet_Change target range is too slow - excel

I have an excel macro used to change formula. The problem is the although the macro works it makes updating the Excel sheet rather laggy. Any suggestion?
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Columns.Count < Me.Columns.Count Then
If Target.Column = 4 Then
If Target.Row >= 49 And Target.Row <= 178 Then
Dim r As Integer
For r = 49 To 178
'AD = 30
Dim MatType As String
MatType = Cells(r, 4).Value
If MatType = "" Then
Cells(r, 30).Value = "0"
Else
MatType = LCase(MatType)
'Plechy
'Trubky
'Jine
If MatType = "pzs" Or MatType = "pzt" Or MatType = "Tahokov" Then
Cells(r, 30).Value = "=(I" & r & " * J" & r & "*L" & r & ") * 2/1000000"
ElseIf MatType = "jac" Or MatType = "jao" Or MatType = "tr" Or MatType = "u" Or MatType = "kr" Or MatType = "L" Or MatType = "op" Or MatType = "Trubky_spec" Then
Cells(r, 30).Value = "=(F" & r & "*I" & r & "*L" & r & ")/1000000"
Else
Cells(r, 30).Value = "0"
End If
End If
Next
End If
End If
End If
Application.EnableEvents = True
End Sub

this will only loop those that change:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo safeout
Application.EnableEvents = False
Dim rng As Range
Set rng = Intersect(Range("D49:D178"), Target)
If Not rng Is Nothing Then
Dim rngCell As Range
For Each rngCell In rng
Dim r As Long
r = rngCell.Row
'AD = 30
Dim MatType As String
MatType = LCase$(rngCell.Value)
'Plechy
'Trubky
'Jine
Select Case MatType
Case "pzs", "pzt", "Tahokov"
Cells(r, 30).Value = CDbl(Cells(r, "I")) * Cells(r, "J") * Cells(r, "L") * 2 / 1000000
Case "jac", "jao", "tr", "u", "kr", "L", "op", "Trubky_spec"
Cells(r, 30).Value = CDbl(Cells(r, "I")) * Cells(r, "F") * Cells(r, "L") / 1000000
Case Else
Cells(r, 30).Value = 0
End Select
Next
End If
safeout:
Application.EnableEvents = True
End Sub

Related

Cutting rows from one sheet and pasting into another in the same workbook - Error 438

I am trying to both colour rows in OC according to the catogarization in column A in OC. Once and issue is closed "C" I want that row cut and pasted into sheet CC. The Debug highlights line Range(Cells(r, 1), Cells(r, 11)).Style = "O"
My next challenge will be to delete the now emplty row from OC, and shifing the remainig rows up.
Here is my code:
Sub Macro2()
'
' Macro2 Macro
'
Dim wb As Workbook
Set wb = ThisWorkbook
Dim OC As Worksheet
Set OC = wb.Sheets("Commercial")
Dim CC As Worksheet
Set CC = wb.Sheets("Closed Commercial")
lrow = OC.Cells(Rows.Count, "L").End(xlUp).Row
clrow = CC.Cells(Rows.Count, "L").End(xlUp).Row
For r = 8 To lrow
For w = 8 To clrow
If Cells(r, 1) = "O" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "O"
ElseIf Cells(r, 1) = "EO" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "EO"
ElseIf Cells(r, 1) = "ED" Then
Range(Cells(r, 1), Cells(r, 8)).Style = "ED"
ElseIf Cells(r, 1) = "RDU" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "RDU"
ElseIf Cells(r, 1) = "RFQs" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "RFQs"
End If
If Cells(r, 12) = "C" Then
Range(Cells(r, 1), Cells(r, 12)).Cut
Range(Cells(w, 1), Cells(w, 12)).Paste
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Next
Next
End Sub
''UPDATE:
'This is my new code, it got rid of the 450 error, but in its stead I am 'getting Object doesn't support this method (438):
' Macro2 Macro
'
Sub Macro2()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim OC As Worksheet
Set OC = wb.Sheets("Commercial")
Dim CC As Worksheet
Set CC = wb.Sheets("Closed Commercial")
lrow = OC.Cells(Rows.Count, "L").End(xlUp).Row
clrow = CC.Cells(Rows.Count, "L").End(xlUp).Offset(1, 0).Row
For r = 8 To lrow
If OC.Cells(r, 1) = "Origin" Then
OC.Range(OC.Cells(r, 1), OC.Cells(r, 11)).Style = "Origin"
ElseIf Cells(r, 1) = "Open" Then
OC.Range(OC.Cells(r, 1), OC.Cells(r, 11)).Style = "Open"
ElseIf Cells(r, 1) = "Disco" Then
OC.Range(OC.Cells(r, 1), OC.Cells(r, 8)).Style = "Disco"
ElseIf OC.Cells(r, 1) = "RDU" Then
OC.Range(OC.Cells(r, 1), OC.Cells(r, 11)).Style = "RDU"
ElseIf OC.Cells(r, 1) = "RFQs" Then
OC.Range(OC.Cells(r, 1), OC.Cells(r, 11)).Style = "RFQs"
End If
Next
For r = 8 To lrow
For w = 8 To clrow
If OC.Cells(r, 12) = "C" Then
OC.Range(OC.Cells(r, 7), OC.Cells(r, 12)).Style = "Closed"
OC.Range(OC.Cells(r, 1), OC.Cells(r, 12)).Copy
'the line below is the issue
CC.Range(CC.Cells(w, 1)).Paste
End If
Next
Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Thank you everyone who took time to comment and answer, this is the final version of the code that works exactly the way I want it to:
Sub Macro2()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim OC As Worksheet
Set OC = wb.Sheets("Commercial")
Dim CC As Worksheet
Set CC = wb.Sheets("Closed Commercial")
lrow = OC.Cells(Rows.Count, "L").End(xlUp).Row
clrow = CC.Cells(Rows.Count, "L").End(xlUp).Offset(1, 0).Row
For r = 8 To lrow
If Cells(r, 1) = "O" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "O"
ElseIf Cells(r, 1) = "EO" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "EO"
ElseIf Cells(r, 1) = "ED" Then
Range(Cells(r, 1), Cells(r, 8)).Style = "ED"
ElseIf Cells(r, 1) = "RDU" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "RDU"
ElseIf Cells(r, 1) = "RFQs" Then
Range(Cells(r, 1), Cells(r, 11)).Style = "RFQs"
End If
Next
For r = 8 To lrow
If OC.Cells(r, 12) = "C" Then
OC.Range(OC.Cells(r, 7), OC.Cells(r, 12)).Style = "Closed"
OC.Cells(r, 1).EntireRow.Copy CC.Cells(clrow, 1)
OC.Cells(r, 1).EntireRow.Delete
clrow = clrow + 1
End If
Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Excel macro taking longtime

I am using the below excel which takes longtime to complete.
Usually i will have 30k records in invoice sheet and GRN sheet.
Can anyone suggest me to complete this task in faster way?
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = Sheets("Invoice").Cells(i, 7).Value And _
Sheets("GRN").Cells(j, 18).Value = Sheets("Invoice").Cells(i, 19).Value Then
Sheets("GRN").Cells(j, 34).Copy
Sheets("Invoice").Cells(i, 48).PasteSpecial Paste:=xlPasteValues
Sheets("GRN").Cells(j, 35).Copy
Sheets("Invoice").Cells(i, 49).PasteSpecial Paste:=xlPasteValues
Sheets("GRN").Cells(j, 36).Copy
Sheets("Invoice").Cells(i, 50).PasteSpecial Paste:=xlPasteValues
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
End Sub
I suggest to do direct transfer of data from one sheet to the other and turn off some applications to make it even fater. Try this one:
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
'turn applications off, to make the macro go faster
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = Sheets("Invoice").Cells(i, 7).Value And _
Sheets("GRN").Cells(j, 18).Value = Sheets("Invoice").Cells(i, 19).Value Then
Sheets("GRN").Cells(j, 34).Copy = Sheets("Invoice").Cells(i, 48)
Sheets("GRN").Cells(j, 35).Copy = Sheets("Invoice").Cells(i, 49)
Sheets("GRN").Cells(j, 36) = Sheets("Invoice").Cells(i, 50)
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
'turn applications back on..
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This one should be a bit faster. Because you don´t get the values of a and b each time when the for j loop begins.
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
a=Sheets("Invoice").Cells(i, 7).Value
b=Sheets("Invoice").Cells(i, 19).Value
c=Sheets("GRN").Cells(j, 34).Value
d=Sheets("GRN").Cells(j, 35).Value
e=Sheets("GRN").Cells(j, 36).Value
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = a And _
Sheets("GRN").Cells(j, 18).Value = b Then
Sheets("Invoice").Cells(i, 48).Value=c
Sheets("Invoice").Cells(i, 49).Value=d
Sheets("Invoice").Cells(i, 50).Value=e
Application.Statusbar= i*j*100/LastInvRow*LastGRNRow & "%"
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
End Sub
The statusbar will show you the progress of your task in %.

Loop through ListBox Multiselection

I'm trying to loop through multiselected list of listbox in excel. but it throws Error "Next without For"
UserForm connects three books. Firstдн, macro should check for matches in book "ToolsDır". If there is a tool, then transfer it from responsible to recipient. then enter this transaction in "TOOLSJOURNAL". and go through all the selected elements of the list box doing the same action. I hope I could explain the problem
Private Sub cmbOK_Click()
Dim wbd, wbs As String
wbd = "...\TOOLS\TOOLSJOURNAL.xlsm"
wbs = "...\TOOLS\TOOLSDIR.xlsm"
If Trim(Me.cboCity.Value) = "" Or Trim(Me.cboReciever.Value) = "" Then
Me.TextDate.SetFocus
MsgBox ("Tool is already in use!")
Else
GetObject (wbs)
Dim lnItem As Long
For lnItem = 0 To Me.ListBox.ListCount - 1
If Me.ListBox.Selected(lnItem) Then
Dim ws As Worksheet
Set ws = Workbooks("TOOLSDIR").Worksheets("TABLE")
Dim rn1, rn2, rn3 As Range
Set rn1 = ws.Range("ID")
Set rn2 = ws.Range("EMPLOYEES")
Set rn3 = ws.Range("DATA")
Dim i, j, k, l As Integer
i = Application.Match(Me.ListBox.Selected(lnItem), ws.Range("ID"), 0)
j = Application.Match(Me.cboRespName.Value, ws.Range("EMPLOYEES"), 0)
k = Application.Match(Me.cboRecName.Value, ws.Range("EMPLOYEES"), 0)
l = rn3.Cells(i, j)
If rn3.Cells(i, j).Value <> 1 Then
MsgBox ("Fill Blank ")
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (False)
Else: rn3.Cells(i, j) = rn3.Cells(i, j) - 1
rn3.Cells(i, k) = rn3.Cells(i, k) + 1
End If
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (True)
With GetObject(wbd)
Dim Database As Worksheet
Set Database = Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL")
Dim NextRow As Long
NextRow = Database.Cells(Database.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
If Database.Range("B4").Value = "" And Database.Range("C4").Value = "" Then
NextRow = NextRow - 1
End If
Database.Cells(NextRow, 3).Value = Me.TextDate.Value
Database.Cells(NextRow, 4).Value = Me.TextPurchaseDate
Database.Cells(NextRow, 5).Value = Me.TextFirstDate.Value
Database.Cells(NextRow, 6).Value = Me.TextDayTotal.Value
Database.Cells(NextRow, 7).Value = Me.cboRegion.Value
Database.Cells(NextRow, 8).Value = Me.cboCity.Value
Database.Cells(NextRow, 9).Value = Me.cboResponsible.Value
Database.Cells(NextRow, 10).Value = Me.cboRespName
Database.Cells(NextRow, 11).Value = Me.ListBox.List(lnItem, 1).Value
Database.Cells(NextRow, 12).Value = Me.ListBox.List(lnItem, 2).Value
Database.Cells(NextRow, 13).Value = Me.ListBox.List(lnItem, 3).Value
Database.Cells(NextRow, 14).Value = Me.cboReciever.Value
Database.Cells(NextRow, 15).Value = Me.cboRecName.Value
Database.Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
If NextRow > 4 Then
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Activate
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Range("B4").Select
Selection.AutoFill Destination:=Range("b4:b" & NextRow)
Range("b4:b" & NextRow).Select
End If
End With
Application.DisplayAlerts = False
Workbooks("TOOLSJOURNAL").Close (True)
Next lnItem
End If
Call resetForm
End Sub

Sum only those that are visible

Recently, I have been trying to code a VBA to assist me in summing a column and divide by counter to get average. However, I have a new requirement that is it is only going to sum up those that are visible. Any idea on how should I proceed? Below is my code,
Sub test3()
Dim FinalRow As Long
Dim Row As Long
Dim counter As Integer
Dim total As Double
counter = 3
total = 0
Dim i As Double
FinalRow = Range("C65536").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(counter, "C")) And Not IsEmpty(ActiveSheet.Cells(Row + 1, "C")) Then
If ActiveSheet.Cells(counter, "B").Value = True Then
ActiveSheet.Cells(Row, "M").Value = 100
For i = counter To Row
If IsEmpty(ActiveSheet.Cells(i, "F")) Then
With ActiveSheet.Cells(i, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
If (.Value - .Offset(0, 2).Value) >= 0 Then
.Font.color = vbRed
Else
.Font.color = vbBlack
End If
End With
End If
Next i
End If
If (ActiveSheet.Cells(Row, "L").Value = 100) Then
For i = counter To Row
If IsEmpty(ActiveSheet.Cells(i, "F")) Then
With ActiveSheet.Cells(i, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
If (.Value - .Offset(0, 2).Value) >= 0 Then
.Font.color = vbRed
Else
.Font.color = vbBlack
End If
End With
End If
Next i
End If
If Not (ActiveSheet.Cells(counter, "B").Value) = True Then
ActiveSheet.Cells(counter, "M").Value = (Application.Sum(Range(ActiveSheet.Cells(counter, "L"), ActiveSheet.Cells(Row, "L")))) / (Row + 1 - counter)
End If
counter = Row + 1
End If
Next
End Sub
This testcode works for me, just change it as you need it:
Sub TestSumme()
Dim Summe As Long
Summe = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets(1).Range("A1:A6").SpecialCells(xlCellTypeVisible))
MsgBox (Summe)
End Sub

Copy-paste cell values to other sheets

I am trying to put together some codes that I found here and there to build up a small inventory, sales program. I am stuck at a point where the customer basket is finalized and sold items in the basket should be saved in relevant sheets.
As an example,basket data is in sheet1 (A4:g22), needs to be written to sheet2 and sheet3 with finding the first empty cell in column A. Thank you very much for your help in advance.
Private Sub EKSKAYDET_Click()
If Not IsNumeric(Me.eksmiktartxt.Value) Then
MsgBox "Miktari Kontrol Ediniz!"
Me.eksmiktartxt.SetFocus
Exit Sub
End If
If Not IsNumeric(Me.eksreznobox.Value) Then
MsgBox "ÜRÜN KODUNU Kontrol Ediniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If eksreznobox.Value = "" Then
MsgBox "ÜRÜN KODU Seçmelisiniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If TextBox23 = 0 And TextBox19 = 0 And TextBox20 = 0 And TextBox21 = 0 And TextBox22 = 0 Then
MsgBox "ÖDEME MİKTARI Girmelisiniz!": Exit Sub
Me.TextBox19.SetFocus
End If
If TextBox25.Value = 0 Then
MsgBox "SEPET BOŞ!"
Exit Sub
End If
If TextBox19 = "" And TextBox20 = "" And TextBox21 = "" And TextBox22 = "" And TextBox23 = "" Then
MsgBox "Tutar Girmelisiniz!":
Exit Sub
End If
If eksreznobox.ListCount = 0 Then Exit Sub
ry_bul = eksreznobox.ListIndex + 3
eksadI = Sheets("STOKKARTLARI").Range("D" & ry_bul).Value
EKSSOYADI = Sheets("STOKKARTLARI").Range("E" & ry_bul).Value
textbox12 = Sheets("STOKKARTLARI").Range("h" & ry_bul).Value
TextBox15 = Sheets("STOKKARTLARI").Range("F" & ry_bul).Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("SATISHAREKETLERİ")
lRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws
.Cells(lRow, 3).Value = Me.eksreznobox.Value
.Cells(lRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lRow, 4).Value = Me.eksadI.Value
.Cells(lRow, 7).Value = Me.eksmiktartxt.Value
.Cells(lRow, 9).Value = Me.ekstutartxt.Value
.Cells(lRow, 8).Value = Me.textbox12.Value
.Cells(lRow, 5).Value = Me.EKSSOYADI.Value
.Cells(lRow, 6).Value = Me.TextBox15.Value
.Cells(lRow, 2).Value = Me.TextBox26.Value
Dim llRow As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("STOK")
llRow = ws1.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws1
.Cells(llRow, 3).Value = Me.eksreznobox.Value
.Cells(llRow, 1).Value = Me.ekstarihtXT.Value
.Cells(llRow, 4).Value = Me.eksadI.Value
.Cells(llRow, 7).Value = Me.eksmiktartxt.Value
.Cells(llRow, 9).Value = Me.ekstutartxt.Value
.Cells(llRow, 8).Value = Me.textbox12.Value
.Cells(llRow, 5).Value = Me.EKSSOYADI.Value
.Cells(llRow, 6).Value = Me.TextBox15.Value
.Cells(llRow, 2).Value = Me.TextBox26.Value
.Cells(llRow, 11).Value = Me.TextBox27.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
Dim lllRow As Long
Dim ws2 As Worksheet
Set ws2 = Worksheets("kasa")
lllRow = ws2.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
Me.TextBox52.Value = "SATIŞ"
With ws2
.Cells(lllRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lllRow, 5).Value = Me.TextBox19.Value
.Cells(lllRow, 6).Value = Me.TextBox20.Value
.Cells(lllRow, 7).Value = Me.TextBox21.Value
.Cells(lllRow, 9).Value = Me.TextBox23.Value
.Cells(lllRow, 3).Value = Me.TextBox51.Value
.Cells(lllRow, 2).Value = Me.TextBox26.Value
.Cells(lllRow, 4).Value = Me.TextBox52.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
With kayit_formu.ListBox6
.BackColor = vbWhite
.ColumnCount = 9
.ColumnWidths = "50;33;45;55;60;55;42;43;60"
.ForeColor = vbBlack
If Sheets("SATISHAREKETLERİ").Range("A1") = Empty Then
.RowSource = Empty
Else
.RowSource = "SATISHAREKETLERİ!a1:i" & [SATISHAREKETLERİ!A1048500].End(3).Row
End If
End With
MsgBox "Bir Kayit Yapildi!"
End With
Me.TextBox25.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G1").Value)
Me.TextBox24.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G2").Value)
End Sub
You can try this code.
Worksheets(“Sheet1″).Range(“A1:G22″).Copy _
Destination:=Worksheets(“Sheet2″).Range(“E5″)

Resources