• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kodları değiştirmem mi gerek ?

A

askhamali

Katılım
9 Ocak 2018
Mesajlar
40
Excel Vers. ve Dili
2007
Kod: 
Sub Diz()
Application.ScreenUpdating = False
Range("J3:L100") = ""
Range("AH1:BZ1000") = ""
son = Cells(Rows.Count, 2).End(3).Row
Range("B2:C" & son).Sort Range("B2"), xlAscending
For i = son To 2 Step -1
If Cells(i, 3) = "" Or Cells(i, 3) = 0 Then GoTo 10
süt = WorksheetFunction.CountA(Range("AH12:BZ12")) + 34
Cells(12, süt) = Cells(i, 2).Value
Cells(11, süt) = Cells(i, 3).Value
Cells(13, süt) = 0
10
Next
x = WorksheetFunction.CountA(Range("AH12:BZ12")) + 33
Range(Cells(14, 34), Cells(1000, x)) = "=IF(ROW(A1)>AH$11,"""",AH$12+AH13)"
Range(Cells(14, 34), Cells(1000, x)) = Range(Cells(14, 34), Cells(1000, x)).Value
Range(Cells(6, 34), Cells(6, x)) = 0
Range("AH3") = "=H3"
Range(Cells(7, 34), Cells(7, x)) = "=MATCH(AH$3,AH$13:AH$1000,1)-AH6"
Range(Cells(3, 35), Cells(3, x)) = "=ROUND(AH3-AH8,2)"
Range(Cells(8, 34), Cells(8, x)) = "=(AH7-1)*AH$12"
Range(Cells(9, 34), Cells(9, x)) = "=AH7-1"
Range("AH1") = "=IF(AH3=AJ1,1,0)"
Range("AJ1") = "=SUM(AH8:BZ8)"
End Sub

 
Sub Yaz()

For i = 34 To 100
If Cells(9, i) = "" Then Exit Sub
If Cells(9, i) = 0 Then GoTo 10
son = Cells(Rows.Count, 10).End(3).Row + 1
Cells(son, 10) = Cells(12, i).Value
Cells(son, 11) = Cells(9, i).Value
Cells(son, 12) = Cells(son, 11) * Cells(son, 10)
10
Next
End Sub
Sub Stoktan_Düş()
If Range("J3") = "" Then Exit Sub
son = Cells(Rows.Count, 10).End(3).Row
For i = 3 To son
x = WorksheetFunction.Match(Cells(i, 10), Range("B1:B100"), 0)
Cells(x, 3) = Cells(x, 3) - Cells(i, 11)
Next
Range("H3") = ""
End Sub

Sub Yeni()
If Range("AH1") = 1 Then Exit Sub
t = WorksheetFunction.CountA(Range("AH6:BZ6")) + 33
For i = t To 34 Step -1
Range(Cells(6, 34), Cells(6, t)) = 0
For j = i To t
If Cells(7, j) < 2 Then GoTo 20
Cells(6, j) = Cells(6, j) + 1
If Range("AH1") = 1 Then Exit Sub
20
Next
Next
End Sub

Bu kodlama bütün işlemler A ve O sütunları arasını ilgilendirdiği halde AH1:BZ1000 AH12:BZ12 AH1 AH3 AJ1 kodlamada geçmesinin hikmetini anlayamadım.

Bunlar BZ arasına tablolar eklediğimde A O sütunları arasındaki hesap tablom çalışmıyor. Ne yapabilirim ?
 
Örnek dosya ekleyebilirseniz kodlarınızı deneyip ne yaptığını daha hızlı anlayabiliriz.
 
B C sütunlarındaki mevcut pul küpürlerine göre J K L sütunlarına H3'e yazılan değer kadar pul kombinasyonu sağlıyor. Ancak AH sütunundan itibaren yaptığım eklemeler bu formülü bozuyor. AH sütunun sağını silersem tekrar düzeliyor.

Kodlar O sütunundan sonrasını ilgilendirmemesi gerekir. Çünkü bütün formül ilk 12-15 sütunda.
 

Ekli dosyalar

Size önerilen kodlar belirttiğiniz hücre aralıklarını kullanarak hesaplama yapıyor. Siz alakasız gibi görüyorsunuz. Fakat kodlar bu hücreleri kullanıyor.

Ben ilgili hücreleri biraz daha sağa doğru kaydırdım.

Sayfanızın kodunu aşağıdaki gibi değiştirin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("H3")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Diz
    Yeni
    If Range("CA1") = 0 Then
    MsgBox "Bulamadı"
    Range("CA1:DZ1000") = ""
    Else
    Yaz
    Range("CA1:DZ1000") = ""
    End If
End Sub

Modüldeki kodu aşağıdaki gibi değiştirin.

Kod: 
Sub Diz()
    Application.ScreenUpdating = False
    Range("J3:L100") = ""
    Range("CA1:DZ1000") = ""
    son = Cells(Rows.Count, 2).End(3).Row
    Range("B2:C" & son).Sort Range("B2"), xlAscending
    For i = son To 2 Step -1
        If Cells(i, 3) = "" Or Cells(i, 3) = 0 Then GoTo 10
        süt = WorksheetFunction.CountA(Range("CA12:DZ12")) + 79
        Cells(12, süt) = Cells(i, 2).Value
        Cells(11, süt) = Cells(i, 3).Value
        Cells(13, süt) = 0
10
    Next
    x = WorksheetFunction.CountA(Range("CA12:DZ12")) + 78
    Range(Cells(14, 79), Cells(1000, x)) = "=IF(ROW(A1)>CA$11,"""",CA$12+CA13)"
    Range(Cells(14, 79), Cells(1000, x)) = Range(Cells(14, 79), Cells(1000, x)).Value
    Range(Cells(6, 79), Cells(6, x)) = 0
    Range("CA3") = "=H3"
    Range(Cells(7, 79), Cells(7, x)) = "=MATCH(CA$3,CA$13:CA$1000,1)-CA6"
    Range(Cells(3, 80), Cells(3, x)) = "=ROUND(CA3-CA8,2)"
    Range(Cells(8, 79), Cells(8, x)) = "=(CA7-1)*CA$12"
    Range(Cells(9, 79), Cells(9, x)) = "=CA7-1"
    Range("CA1") = "=IF(CA3=CC1,1,0)"
    Range("CC1") = "=SUM(CA8:DZ8)"
End Sub

Sub Yaz()
    For i = 79 To 150
        If Cells(9, i) = "" Then Exit Sub
        If Cells(9, i) = 0 Then GoTo 10
        son = Cells(Rows.Count, 10).End(3).Row + 1
        Cells(son, 10) = Cells(12, i).Value
        Cells(son, 11) = Cells(9, i).Value
        Cells(son, 12) = Cells(son, 11) * Cells(son, 10)
10
    Next
End Sub

Sub Stoktan_Düş()
    If Range("J3") = "" Then Exit Sub
    son = Cells(Rows.Count, 10).End(3).Row
    For i = 3 To son
        x = WorksheetFunction.Match(Cells(i, 10), Range("B1:B100"), 0)
        Cells(x, 3) = Cells(x, 3) - Cells(i, 11)
    Next
    Range("H3") = ""
End Sub

Sub Yeni()
    If Range("CA1") = 1 Then Exit Sub
    t = WorksheetFunction.CountA(Range("CA6:DZ6")) + 78
    For i = t To 79 Step -1
        Range(Cells(6, 79), Cells(6, t)) = 0
        For j = i To t
            If Cells(7, j) < 2 Then GoTo 20
            Cells(6, j) = Cells(6, j) + 1
            If Range("CA1") = 1 Then Exit Sub
20      Next
    Next
End Sub
 
Çok teşekkür ederim hocam. Cevaplarınız işimi çok kolaylaştırıyor. Emeğinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst