Kasa çizelgesinde Özet tablolar sonuçlar

[modoste]

sayın ömer hocam bir sorunum var
benim bilgisayarımda makronun sonuçlarını alabiliyorum
o dosyayı flashdisk le kasayı gerçek tutan arkadaşımın bilgisayarınca açtığım anda makro güvenliği gibi bi pencere açılıyo.
ben normal çalışır (office 2003 o bilgisayarda) diye düşünüyodum ama çalıştıramadım
bu konu ile ilgili yardım edermisiniz.
Makro ayarları mı bilemiyorum . şu an arkadaşımın bilgisayarına geçtim forumu forumdaki sorumu sizin modülü burdan kopyalayarak denemeye çalışcam.

sonuç bu bilgisayarda herşeyi yeniden yazdığım anda sonuca ulaştım ama diğer türlü nerde hata var anlayamadım

 

[Ömer]

Linki inceleyiniz.

Makroları etkin kılmak.Güvenlik düzeyini düşürmek

.

 

[modoste]

link için teşekkür ederim hocam.

 

[modoste]

sayın ömer hocam merhaba tekrar
kasa çizelgesinden makro ile ilgili son sorum şu olucak
I1:I30 arasında toplam 30 koddan oluşan (1 den 30 a kadar) listede sadece yazılan kodlara karşılık gelen kasa hareketlerini listelemesidir.
listeleme kriteri 1 yada birden fazla olabilir. I1:I30 arasında hangi sayılar varsa o sayılara göre listeleme yapacak.
listelerken küçükten büyüğe doğru sıralatılabiliyor mu ( varsa önce 1 leri sıralayacak sonra 2 leri .....)

 

[Ömer]

Tarih ölçütü dikkate alınmadan sadece koda göre mi listelenecek yoksa hepsi birlikte mi?

Ayrıca sayfalardaki kod sütunlarını boş bırakmışsınız. Deneme yapabilmem için boş dosya değil tahmini verilerde olsa birkaç veri girerek ekleyiniz. Dosya eklerken bu konulara özen göstermenizi rica ederim.

.

 

[modoste]

Sayın Ömer Hocam
Tarih kriterleri yine geçerli olucak (belirli tarih arası döküm)
örnek dosyayı yeniliyorum 1-2 sekmelerinde kod yerlerine bir takım sayılar yazdım
sonuçlar sekmesinde G1 ve H1 e tarih yazdım.
I1:I30 arasına (1-2-3-6-9-10-11-12-13-14) kodlarını yazarak
dosyamı yeniden ekliyorum

 

[Ömer]

Eski kodları silerek aşağıdaki kodları ekleyiniz.

[COLOR=darkgreen]' Tarihleri icmallere aktaran kodlar[/COLOR]
[COLOR=red]Sub TarihVer(kod1 As String)[/COLOR]
 
Dim c As Range, ilkadres As Variant, fark As Integer, i As Integer
 
For i = 1 To Worksheets.Count
    With Sheets(i)
        If .Name <> "Sonuçlar" Then
            .Range("A:A").ClearContents
            Set c = .Range("B:B").Find(1, LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                ilkadres = c.Address
                Do
                    If c.Row = 5 Then
                        fark = 4
                    Else
                        fark = 3
                    End If
 
                    son = .Range("B" & c.Row).End(xlDown).Row
                     .Range("A" & c.Row & ":A" & son) = _
                        .Range("H" & c.Row - fark)
 
                    Set c = .Range("B:B").FindNext(c)
                Loop While Not c Is Nothing And c.Address <> ilkadres
            End If
        End If
    End With
Next i
 
[COLOR=red]End Sub[/COLOR]
 
[COLOR=darkgreen]' Ölçüte göre sayfalardan veri alan kodlar[/COLOR]
[COLOR=blue]Sub SayfalardanAktar(kod2 As String)[/COLOR]
 
Dim c As Range, sat As Long, ilkadres As Variant, j As Integer
 
Sheets("Sonuçlar").Select
Range("A4:A" & Rows.Count).ClearContents
Range("C4:H" & Rows.Count).ClearContents
 
sat = 4
For i = 1 To Worksheets.Count
    With Sheets(i)
        If .Name <> "Sonuçlar" Then
            For j = 1 To Cells(Rows.Count, "I").End(xlUp).Row
                If Cells(j, "I") <> "" Then
                    Set c = .[D:D].Find(Cells(j, "I"), LookIn:=xlValues, _
                    LookAt:=xlWhole)
                    If Not c Is Nothing Then
                        ilkadres = c.Address
                        Do
 
                            If .Range("A" & c.Row) >= [G1] And _
                            .Range("A" & c.Row) <= [H1] Then
                                .Range("C" & c.Row & ":H" & c.Row).Copy
                                Range("C" & sat).PasteSpecial xlPasteValues, _
                                xlNone
                                Range("A" & sat) = .Range("A" & c.Row)
                                sat = sat + 1
                            End If
 
                            Set c = .[D:D].FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> ilkadres
                    End If
                End If
            Next j
        End If
    End With
Next i
 
Application.CutCopyMode = False: [C4].Select
 
[COLOR=blue]End Sub[/COLOR]
 
[COLOR=darkgreen]'İki kodu birleştiren yordam[/COLOR]
[COLOR=darkred]Sub SonuclarıYazdır()[/COLOR]
 
Application.ScreenUpdating = False
 
    [COLOR=red]TarihVer "kod1"[/COLOR]
    [COLOR=blue]SayfalardanAktar "kod2"[/COLOR]
 
Application.ScreenUpdating = True
 
[COLOR=darkred]End Sub[/COLOR]

.

 

[modoste]

sayın Ömer Hocam çözümünüzü uyguladım doğru sonuçlar aldım.
msajınızı alır almaz uyguladım foruma geri döncektim fakat kullanıcıyoğunluğu nedeniyle bağlantı kurulamıyo bazen o yüzden teşekkür lerimi şimdi sunuyorum.

kısa bi süre sonra 100-150 sekmeli piyasa firmaları ile ilgili makrolu çözüm isteyecem sizlerden ve diğer hocalarımdan daha önce aynı çizelgeden başka bir sonuç için soru sormuştum cevapları almıştım.