Soru düzgün çalışan mevcut kodu hızlandırma desteği

barış kaya' Alıntı:

hayırlı akşamlar hocalarım
uzunca bi kodumuz var
kod doğru çalışıyor
fakat hızlandırma desteği gerekiyor
yardımcı olmanız mümkün müdür

Public secim

Private Sub Worksheet_Change(ByVal Target As Range)
If ((Target.Row - 1) Mod 37) = -1 Or Target.Row > 37000 Then Exit Sub
sutun = Target.Column
satBas = Target.Row: SatBit = satBas + 36

If Target.Column = 13 Then
If Sheets("Bilgi").Range("E20").Value <> "Kapalı" Then
MsgBox "ÖN ÖDEMELİ FİYAT SABİTLEME DEVREDE OLDUĞU İÇİN" & vbCrLf & "BARKODLU İŞLEM YAPAMAZSINIZ !", vbInformation, "EPAK AMBALAJ"
Else

If Target.Offset(-2, -7).Value = "Tarih" Then
Target.Offset(-2, -6) = Date: Target.Offset(-2, -5) = Time
If Range("T36").Value = "" Then
Target.Offset(-6, 7).ClearContents
Target.Offset(31, 7) = "T"
End If
End If

If Target.Offset(0, -5).Value <> "" Then
Columns("DSS").Select
Selection.Find(What:=Target.Offset(0, 0).Value, LookIn:=xlValues).Select
Target.Cells(1, 1).Offset(0, 3).Value = Range(ActiveCell.Address).Offset(0, 3).Value
End If

If Target.Value = 0 Then Range(Cells(Target.Row, "I"), Cells(Target.Row + 1, "Q")).ClearContents
Target.Offset(2, 0).Select
If Target.Value = 0 And Target.Offset(-2, -7).Value = "Tarih" Then
Target.Offset(-2, -6).ClearContents: Target.Offset(-2, -5).ClearContents
If Range("T36").Value = "" And Target.Offset(-7, 6).Value = "" Then
Target.Offset(-6, 7) = "T"
Target.Offset(31, 7).ClearContents
End If
End If
End If
End If

If Target.Column = 14 Then
If Target.Offset(0, 2).Value <> "" Then
Columns("DVV").Select
Selection.Find(What:=Target.Offset(0, 2).Value, LookIn:=xlValues).Select
Target.Cells(1, 1).Offset(0, -5).Value = Range(ActiveCell.Address).Offset(0, 7).Value
Target.Cells(1, 1).Offset(0, -4).Value = Range(ActiveCell.Address).Offset(0, -1).Value
Target.Cells(1, 1).Offset(0, 1).Value = Range(ActiveCell.Address).Offset(0, 2).Value
If Target.Value < Range(ActiveCell.Address).Offset(0, 1).Value Then
Target.Cells(1, 1).Offset(0, 3).Value = Range(ActiveCell.Address).Offset(0, 3).Value
Target.Offset(2, -1).Select
Else
Target.Cells(1, 1).Offset(0, 3).Value = Range(ActiveCell.Address).Offset(0, 4).Value
Target.Offset(2, -1).Select
End If
End If

If Sheets("Bilgi").Range("B25").Value = "KDV'li" Then
Target.Offset(0, 3).Value = Target.Offset(0, 3).Value + (Target.Offset(0, 3).Value * Target.Offset(0, -4).Value)
End If
End If

If Target.Column = 16 Then
If Sheets("Bilgi").Range("E20").Value <> "Kapalı" Then
MsgBox "ÖN ÖDEMELİ FİYAT SABİTLEME DEVREDE OLDUĞU İÇİN" & vbCrLf & "BARKODLU İŞLEM YAPAMAZSINIZ !", vbInformation, "EPAK AMBALAJ"

ElseIf Target.Offset(0, -8).Value <> "" Then
Target.Offset(0, -2).Value = 1

If Target.Offset(-2, -10).Value = "Tarih" Then
Target.Offset(-2, -9) = Date: Target.Offset(-2, -8) = Time
End If
End If
End If

If ((Target.Row - 1) Mod 37) = 35 <> 0 And Target.Column = 17 Then

Target.Offset(0, 1).ClearContents: Target.Offset(0, -10).ClearContents

If Target.Offset(-3, 0) = "" And Target.Offset(0, 2) <> "" Then
cevap = MsgBox("KREDİ KARTI MI ÇEKİLDİ !", vbYesNo)

If cevap = vbYes Then
Target.Offset(0, -10).Value = -Target.Offset(0, 2).Value * Sheets("Bilgi").Range("E38").Value
End If
End If

If Target.Offset(-30, -1).Value = "" Then
Target.Offset(-32, -10).ClearContents: Target.Offset(-32, -9).ClearContents
If Target.Value <> 0 Then Target.Offset(-32, -10) = Target.Offset(0, 0): Target.Offset(-32, -9) = Time
End If
End If

Select Case sutun
Case 23, 33, 43, 53, 63, 73, 83, 93, 103, 113
Target.Offset(0, 0).Select
End Select

Select Case sutun
Case 30, 40, 50, 60, 70, 80, 90, 100, 110, 120

If Target.Row <= 37 Then Exit Sub

Dim ilk As Long, son As Long
Dim arananMetin As String
Dim aralik As Range, bulunan As Range
Dim ilkAdres As String

ilk = Int((Target.Row - 1) / 37) * 37 + 6: son = ilk + 24

If Sheets("Cari").Range("T36").Value = "" _
And Target.Offset(0, -7).Value = Target.Offset(-37, -7).Value Then

If UCase(Target.Value) = "F" Then
Application.EnableEvents = False
Target.Value = Target.Offset(-37, 0).Value
Application.EnableEvents = True
End If

If Sheets("Bilgi").Range("E20").Value = "Aktif" Then
Application.EnableEvents = False
Target.Value = Target.Offset(-37, 0).Value
Application.EnableEvents = True
End If
End If

arananMetin = Target.Offset(0, -7).Value
If arananMetin = "" Then Exit Sub

Set aralik = Sheets("Cari").Range("P" & ilk & "" & son)
Set bulunan = aralik.Find(arananMetin, LookAt:=xlWhole)

If Not bulunan Is Nothing Then
ilkAdres = bulunan.Address
Application.EnableEvents = False
Do
Cells(bulunan.Row, bulunan.Column + 1).Value = Target.Value
Set bulunan = aralik.FindNext(bulunan)
Loop While Not bulunan Is Nothing And bulunan.Address <> ilkAdres
Application.EnableEvents = True
End If

If Sheets("Bilgi").Range("E20").Value = "Kapalı" Then
If Target.Value < Target.Offset(0, -1).Value Then
Application.EnableEvents = False
MsgBox "ZARAR EDER !" & vbCrLf & "TUTARI YENİDEN YAZINIZ !", vbInformation, "EPAK AMBALAJ"
Application.EnableEvents = True
Exit Sub
End If
End If
End Select

If sutun = 20 Then
If Target = "w" Or Target = "W" Then
Range(Cells(Target.Row, "N"), Cells(Target.Row + 36, "S")).Select
Selection.Copy
ActiveWorkbook.FollowHyperlink Address:="

Bu bağlantı ziyaretçiler için gizlenmiştir. Görmek için lütfen giriş yapın veya üye olun.

" & Worksheets("Bilgi").Range("B12").Value
Application.Wait (Now + TimeValue("00:00:011"))
If Target.Offset(1, -1) = "" Then
mesaj = Worksheets("Bilgi").Range("B15").Value
Else
mesaj = Worksheets("Bilgi").Range("B16").Value
End If
SendKeys (mesaj & "^v")
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("~")
SendKeys "{NUMLOCK}"
End If

If Target = "y" Or Target = "Y" Then
Range(Cells(Target.Row, "N"), Cells(Target.Row + 36, "S")).Select
PageSetup.PrintArea = Selection.Address
PrintOut Copies:=1
PageSetup.PrintArea = ""
End If

If Target = "EPAK AMBALAJ" Then
If Target.Offset(0, -11).Value <> "Sepet Aktif" Then

Range(Cells(Target.Row - 37, "V"), Cells(Target.Row - 1, "DP")).Select
Selection.Copy
Range(Cells(satBas, "V"), Cells(SatBit, "DP")).Select
ActiveSheet.Paste
End If

If Sheets("Bilgi").Range("E20").Value = "Kapalı" Then
Range("FT39:JN75").Value = Range(Cells(Target.Row - 37, "V"), Cells(Target.Row - 1, "DP")).Value
Range(Cells(satBas, "V"), Cells(SatBit, "DP")).Value = Range("FT2:JN38").Value
Exit Sub
End If
Target.Offset(0, 1).Select
End If
End If

If ((Target.Row - 1) Mod 37) = 35 <> 0 And Target.Column = 19 Then
If Target.Offset(0, 0) <> "" And Target.Offset(1, 1) <> "T" And Target.Offset(-35, 1) <> "i" And Target.Offset(-35, 1) <> "İ" Then
cevap = MsgBox("TUTAR GİRDİĞİNİZ YER HATALIYDI !" & vbCrLf & "DEVAM İÇİN [EVET]" & vbCrLf & "İPTAL İÇİN [HAYIR]", vbYesNo)

If cevap = vbYes Then
Target.Offset(-35, 1).Value = "İ"
End If

If cevap = vbNo Then
Target.Offset(0, 0).ClearContents

Dim bul
Set bul = Sheets("Cari").[T:T].Find("T", LookIn:=xlValues, LookAt:=xlPart)
If Not bul Is Nothing Then: Sheets("Cari").Select: bul(0, 0).Activate
MsgBox "UYGUN YERE YÖNLENDİRİLDİNİZ !" & vbCrLf & "TEKRAR BURAYA YAZABİLİRSİNİZ !", vbInformation, "EPAK AMBALAJ"
Exit Sub
End If
End If

If Target.Value <> 0 Then Target.Offset(0, -2) = Date
If Target.Value = 0 Then Target.Offset(0, -2).ClearContents
End If

If ActiveWorkbook.Worksheets("Bilgi").Range("B14") = "Evet" Then
cevap = MsgBox("WHATSAPP'TAN GÖNDERİLSİN Mİ ?", vbYesNo)

If cevap = vbYes Then
Target.Offset(-35, 1).Value = "w"
End If
End If

If ((Target.Column - 1) Mod 10) <> 0 Or Target.Column > 111 Then Exit Sub
Application.ScreenUpdating = False

Target.Offset(0, 6).Value = Format(Date, "dd/mmm/ddd/yy ") & Format(Time, "hh:mm")
Columns("DVV").Select
Selection.Find(What:=Target.Offset(0, 2).Value, LookIn:=xlValues).Select
Target.Cells(1, 1).Offset(0, 1).Value = Range(ActiveCell.Address).Offset(0, 2).Value
Target.Cells(1, 1).Offset(0, 7).Value = Range(ActiveCell.Address).Offset(0, -1).Value
Target.Cells(1, 1).Offset(0, 8).Value = Range(ActiveCell.Address).Offset(0, 7).Value
If Target.Value < Range(ActiveCell.Address).Offset(0, 1).Value Then
Target.Cells(1, 1).Offset(0, 9).Value = Range(ActiveCell.Address).Offset(0, 3).Value
Target.Offset(0, 0).Select
Else
Target.Cells(1, 1).Offset(0, 9).Value = Range(ActiveCell.Address).Offset(0, 4).Value
Target.Offset(0, 0).Select
End If
If Sheets("Bilgi").Range("B25").Value = "KDV'li" Then
Target.Offset(0, 9).Value = Target.Offset(0, 9).Value + (Target.Offset(0, 7).Value * Target.Offset(0, 9).Value)
Application.ScreenUpdating = True
End If

If ((Target.Column - 1) Mod 10) <> 0 Or Target.Column > 111 Then Exit Sub
Application.EnableEvents = False
ilk = Int((Target.Row - 1) / 37) * 37 + 6: son = ilk + 24
If Cells(ilk + 30, 20) <> "R" And Cells(ilk - 5, 20) <> "i" And Cells(ilk - 5, 20) <> "İ" Then
Application.EnableEvents = True
MsgBox "BU ALANDA İŞLEM YAPAMAZSINIZ !" & vbCrLf & "UYGUN YERE YÖNLENDİRİLİYORSUNUZ !", vbInformation, "EPAK AMBALAJ"
Set bul = Sheets("Cari").[T:T].Find("R", LookIn:=xlValues, LookAt:=xlPart)
If Not bul Is Nothing Then: Sheets("Cari").Select: bul.Activate
Selection.Offset(-15, 1).Activate
Exit Sub
End If

If Target.Offset(0, 2) = "" Or Target.Offset(0, 2) = 0 Then
MsgBox "ÜRÜN KISMI BOŞKEN İŞLEM YAPAMAZSINIZ !" & vbCrLf & "ÖNCE ÜRÜN SEÇİMİ YAPMALISINIZ !", vbInformation, "EPAK AMBALAJ"
Target.ClearContents: GoTo 10
End If

bul = 0
For s = ilk To son
bak = Cells(s, 16)
If bak = secim Then: bul = s: Exit For
Next
If bul > 0 And Target = Empty Then
Range("I" & bul & ":Q" & bul + 1).ClearContents
Range("I" & bul).Resize(son - bul, 9) = Range("I" & bul + 2 & ":Q" & son + 1).Value
Range("I" & son & ":Q" & son).ClearContents
If bul = ilk And Cells(ilk, 16) = "" Then Cells(ilk - 2, 7).ClearContents: Cells(ilk - 2, 8).ClearContents
If Range("T36").Value = "" Then
If Cells(ilk, 16) = "" And Cells(ilk - 7, 19) = "" Then Cells(ilk - 6, 20) = "T": Cells(ilk + 31, 20) = ""
End If
GoTo 10

ElseIf bul > 0 And Not Target = Empty Then
Cells(bul, 14) = Target.Value: Cells(bul, 9) = Target.Offset(0, 8): Cells(bul, 10) = Target.Offset(0, 7): Cells(bul, 15) = Target.Offset(0, 1): Cells(bul + 1, 16) = Target.Offset(0, 3): Cells(bul, 17) = Target.Offset(0, 9): GoTo 10
End If

If ((Target.Column - 1) Mod 10) = 0 And Not IsNumeric(Target.Value) Then
MsgBox "SAYI DIŞINDA BİR VERİ GİRDİNİZ !" & vbCrLf & "BU ALANA SADECE SAYI YAZILABİLİR !", vbInformation, "EPAK AMBALAJ"
Target.ClearContents: Target.Activate
ElseIf WorksheetFunction.CountBlank(Range("P" & son & "" & son)) = 0 Then
MsgBox "SEPET DOLDU !" & vbCrLf & "SONRAKİ SAYFADAN DEVAM EDİNİZ !", vbInformation, "EPAK AMBALAJ"
Target.ClearContents: Target.Activate: GoTo 10
Else

XD = Cells(son, 14).End(3).Row + 2
If ilk = XD Then: Cells(ilk - 2, 7) = Date: Cells(ilk - 2, 8) = Time
Cells(XD, 14) = Target.Value: Cells(XD, 9) = Target.Offset(0, 8)
Cells(XD, 14) = Target.Value: Cells(XD, 10) = Target.Offset(0, 7)
Cells(XD, 14) = Target.Value: Cells(XD, 15) = Target.Offset(0, 1)
Cells(XD, 14) = Target.Value: Cells(XD, 16) = Target.Offset(0, 2)
Cells(XD, 14) = Target.Value: Cells(XD + 1, 16) = Target.Offset(0, 3)
Cells(XD, 14) = Target.Value: Cells(XD, 17) = Target.Offset(0, 9)

If Range("T36").Value = "" Then
If ilk = XD Then: Cells(ilk - 6, 20) = "": Cells(ilk + 31, 20) = "T"
End If
End If
10: Application.EnableEvents = True

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column < 10 Or Target.Column > 111 Or Target.Row > 37000 Or ((Target.Column - 1) Mod 10) <> 0 Then Exit Sub
If Selection.Count > 1 Then Exit Sub
secim = Target.Offset(0, 2)
End Sub

Genişletmek için tıkla...

volki_112' Alıntı:

deneyiniz.
HTML:

Kod: Kodları Kopyala

İçeriği görebilmek için Giriş yap ya da Üye ol.

Genişletmek için tıkla...