Verileri toplayarak arka sayfada raporlama

[Galus]

Verileri toplayarak arka sayfada raporlama yapmak istedim. Bazı kodlar denedim. Malesef olmadı. Taşıma suyla değirmen dönmüyor. Bir el atacak hayırsevere ihtiyacım var.

Saygılar...

 

[N.Ziya Hiçdurmaz]

yanıt

Sub raporla()
Dim son As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("sayfa2")
s2.[a2:a100].ClearContents
For son = s1.[c65536].End(3).Row To 2 Step -1
If WorksheetFunction.CountIf(s1.Range("c1:c" & son), s1.Range("c" & son)) = 1 Then
s = s + 1
s2.Range("a" & s + 1) = s1.Range("c" & son).Value
End If
Next
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Galus]

Sayın V.Basic For Applications,

İlginize teşekkürler. Yalnız sadece ürünler geliyor. Sayfa1 deki"Ürünlerin Mikarları da toplatılarak gelmesi gerekiyordu.

Teşekkürler..

Saygılar..

 

[Galus]

Üstadlar şuna bir el atıverseniz.

Saygılar..

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub AktarTopla()
Dim a, i, n, k, b()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("c2:d" & s1.[d65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 1)
                    .Add a(i, 1), n
                End If
                    b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 2)
            End If
    Next
End With
s2.Range("a2:c1000").ClearContents
s2.[a2].Resize(n, 3).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Galus]

Sayın Ripek,

Çok teşekkürler....

Saygılarımla...

 

[zeynepk]

Ripek benimde bir sorum olacak.

ekteki dosyaya iki kolon daha ekledim. (Gerçek dosyamda buna benzer 5-6 kolon daha eklenecek ama ana fikri öğrenirsem uygulamayı tek başıma yapabileceğimi düşünüyorum)

Bu iki kolondaki bilgiler text olup ürün bilgisi gibi tek bir satırda birleşmeleri gerekiyor. Ancak ürünlerin karşısına bu iki kolonda farklı bilgi girilmişse hata mesajı vererek işlemin yapılmasını engellemesini istiyorum. (Hatalar düzeltilmeden makro çalışmasın)

Mümkünmü?:???:

 

[zeynepk]

pardon dosya eklemeyi unutmuşum. ekliyorum:mrgreen:

 

[Recep İpek]

2.sayfada nasıl bir sonuç istediğinizi yazarsanız, sorunuzu net olarak anlayabiliriz.

 

[zeynepk]

Ripek ben dosyanın içerisinde açıklamaları yapmaya çalıştım umarım başarılı olmuşumdur. Yardımların için gerçekten çok teşekkür ederim. Aslına bakarsan bu sorunun çözülmesi benim yaptığım bir çok iş için kolaylık olacak

syg

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub AktarTopla()
Dim a, i, n, k, z, b()
Dim durum As Boolean
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("c2:f" & s1.[c65536].End(3).Row).Value
ReDim b(1 To UBound(a, 1), 1 To 7)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                z = a(i, 1) & ":" & a(i, 3) & ":" & a(i, 4)
                If Not .exists(z) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 1)
                    .Add z, n
                    b(n, 4) = a(i, 3)
                    b(n, 5) = a(i, 4)
                   End If
                    b(.Item(z), 3) = b(.Item(z), 3) + a(i, 2)
                    b(.Item(z), 6) = b(.Item(z), 6) + 1
                    If b(.Item(z), 6) = 1 Then
                    b(.Item(z), 7) = "Hatalı Kayıt"
                    Else
                    b(.Item(z), 7) = ""
                    End If
            End If
        Next
End With
s2.Range("a2:g1000").ClearContents
s2.[a2].Resize(n, 7).Value = b
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[zeynepk]

ripek size gerçekten çok teşekkür ederim.