• DİKKAT

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

Soru VBA İLE SIRALAMA

Mukteda

Mukteda

Katılım
1 Aralık 2010
Mesajlar
313
Excel Vers. ve Dili
Office 2010
Merhabalar,

Ekteki dosyada, RAPOR sayfasında, A kolonunu yeni ekleyip "Gurup Açıklaması" başlığını ekledim.

1- Mevcut VBA içerisinde, ÜRETİM-VERİ sayfasındaki gurup açıklamasını RAPOR sayfasına nasıl getirebilirim?

2- RAPOR Sayfasında, gurup açıklaması geldiktan sonra, ilk önce A kolonuna daha sonra C kolonuna göre sıralama nasıl yaptırabilirim?

VBA Kodları aşağıdadır:


Kod: 
Private Sub Worksheet_Activate()
Dim sat As Worksheet, ur As Worksheet
sayfa = Array("SATIS-VERİ", "ÜRETİM-VERİ")
Set s = CreateObject("Scripting.Dictionary")
For Each syf In sayfa
    With Sheets(syf)
        For Each hcr In .Range(.Range("F2"), .Cells(Rows.Count, "F").End(3))
            If Not s.exists(hcr.Value) Then s.Add hcr.Value, hcr.Offset(0, 1).Value
        Next
    End With
Next
Me.Range("B2:B10000").ClearContents
Me.Range("B2").Resize(s.Count).Value = Application.Transpose(s.items())
Me.Range("C2").Resize(s.Count).Value = Application.Transpose(s.keys())
End Sub

Kitap2.xlsm dosyasını indir - download

Kitap2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc
 
Doğru anladıysam aşağıdaki kodları dener misiniz?

PHP: 
Private Sub Worksheet_Activate()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ÜRETİM-VERİ")
Set s2 = Sheets("SATIS-VERİ")

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
Me.Range("A2:C10000").ClearContents

SORGU = "select distinct GURUP, [MALZEME AÇIKLAMASI], [MALZEME KODU] from [ÜRETİM-VERİ$] where [MALZEME KODU] is not null"
Set rs = con.Execute(SORGU)
[A2].CopyFromRecordset rs

son = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row, Cells(Rows.Count, "C").End(3).Row) + 1
SORGU = "select distinct GURUP, [MALZEME AÇIKLAMASI], [MALZEME KODU] from [SATIS-VERİ$] where [MALZEME KODU] is not null"
Set rs = con.Execute(SORGU)
Cells(son, "A").CopyFromRecordset rs

enson = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row, Cells(Rows.Count, "C").End(3).Row) + 1

ActiveSheet.Range("$A$1:$C$" & enson).RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
End Sub
 
Merhaba Yusuf Bey,

İlginiz ve kıymetli yardımınız için çok teşekkür ederim.

Vermiş olduğunuz kod düzgün çalıştı, tamamdır. Ancak vaktim çok sınırlı olduğu için detaylı kontrol sağlayamıyorum.

Aslında bu sorun aşağıdaki konunun devamı idi...
Orada yanıt alamadığım için ve ilave farklı bir sorun olduğu için yeni konu açmak zorunda kaldım.

Aşağıdaki konudaki sorunun yanıtı sizin yazdığınız VBA karşılığı mıdır? (VBA Kodları tamamen değiştiği için bu şekilde sormak istedim.)

Soru - HER İKİ SAYFADA ORTAK OLAN MALZEMELER

Merhabalar, Elimde 900 küsür satır malzeme kodlarının olduğu bir veri sayfası var. Bunların üretim ve satış karşılığını aylara göre ÇOKEĞERSAY ile bulabiliyorum. Burada sorun yok. Ancak raporlama yaparken 900 küsür satır malzeme üzerinde olduğu için pek anlaşılır olmuyor. Filtre seçeneğini...
excel.web.tr excel.web.tr
 
Benim çözümüm ordaki #4. mesajdaki çözümle benzer, yani önce iki sayfayı üöüncü sayfada topluyor sonra da 2. sayfada yinelenenleri kaldırıyor.

Muhtemelen istediğiniz çözüm olmuştur, siz kontrol edin, eksik ya da hata varsa ona göre bakalım.
 
Yusuf Bey'in kodunda, 2 SQL sorgusu birleştirilerek tek sorgu kullanılabilir;

C#: 
SORGU = " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [ÜRETİM-VERİ$] Where [MALZEME KODU] Is Not Null " & _
        " Union All " & _
        " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [SATIS-VERİ$] Where [MALZEME KODU] Is Not Null"

.
 
Haluk üstadım ben kodları birleştirmeyi bir türlü öğrenememiştim, bu desteğiniz için teşekkür ederim.

Ancak kodu denediğimde copyfromrecordset satırında Type missmatch hatası verdi.
 
YUSUF44' Alıntı:
Muhtemelen istediğiniz çözüm olmuştur, siz kontrol edin,
Genişletmek için tıkla ...

Merhaba Yusuf Bey,

Tekraren şükranlarımı sunarım. Çok sağ olun.

Bir önceki konuda ÖMER BEY yazmış olduğu kodda 248 satır geliyor, sizin kodlarınızda 249 satır geliyor. Fark ne olabilir?

Örnek-2: Ürün-8 Satış sayfasında var, ancak üretim sayfasında yoktur.
Sonuç: RAPOR sayfasına Ürün-8 açıklaması ile birlikte gelecektir. (Mevcut durumda farklı olan malzemeleri tablonun en altına "ayrıca" ekliyor. Farkları da tablonun "içine" yazmalı ve tabloyu bir bütün olarak sıralamalıdır.)

Örnek-3: Ürün-6 Üretim sayfasında var, ancak satış sayfasında yoktur.
Sonuç: RAPOR sayfasına Ürün-6 açıklaması ile birlikte gelecektir. (Mevcut durumda farklı olan malzemeleri tablonun en altına "ayrıca" ekliyor. Farkları da tablonun "içine" yazmalı ve tabloyu bir bütün olarak sıralamalıdır.)

Haluk' Alıntı:
Yusuf Bey'in kodunda, 2 SQL sorgusu birleştirilerek tek sorgu kullanılabilir;
Genişletmek için tıkla ...

Haluk Bey,

Değerli yardımınız için teşekkür ederim.

Kodları birleştiremedim, hata verdi. Bir bütün olarak paylaşabilir misiniz?
 
YUSUF44' Alıntı:
Haluk üstadım ben kodları birleştirmeyi bir türlü öğrenememiştim, bu desteğiniz için teşekkür ederim.

Ancak kodu denediğimde copyfromrecordset satırında Type missmatch hatası verdi.
Genişletmek için tıkla ...


Geri dönen sonuçların içeriğini bilmiyorum ama bende bu şekilde çalıştı;

C#: 
Private Sub Worksheet_Activate()
    Dim s1 As Worksheet, s2 As Worksheet, Con As Object, RS As Object, SORGU As String

    Set s1 = Sheets("ÜRETİM-VERİ")
    Set s2 = Sheets("SATIS-VERİ")

    Set Con = CreateObject("ADODB.Connection")
    Con.Open "Provider= Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & ";Extended Properties= 'Excel 12.0; HDR=YES'"

    Range("A2:C10000").ClearContents

    SORGU = " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [ÜRETİM-VERİ$] Where [MALZEME KODU] Is Not Null " & _
            " Union All " & _
            " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [SATIS-VERİ$] Where [MALZEME KODU] Is Not Null"

    Set RS = Con.Execute(SORGU)
    [A2].CopyFromRecordset RS
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Geri dönen sonuçların içeriğini bilmiyorum ama bende bu şekilde çalıştı;
Genişletmek için tıkla ...

Haluk Bey,
Tamamdır, ben de çalıştırdım, bu kısımda bir sorun yoktur. Teşekkür ederim.
Ancak 485 satır geldi. ;)

Sorunun çözümü için Yusuf Bey veya siz 7 Numaralı mesajı inceleyebilirseniz sevinirim.

Esenlikle kalınız.
 
Ben hala çalıştıramadım, örnek dosyada sıkıntı var sanıyorum.

Alternatif olarak aşağıdaki gibi de kullanılabilir:

PHP: 
Private Sub Worksheet_Activate()
    Dim Con As Object, RS As Object, SORGU As String

    Dim s1 As Worksheet, s2 As Worksheet, son As Integer
    Set s1 = Sheets("ÜRETİM-VERİ")
    Set s2 = Sheets("SATIS-VERİ")
    Range("A2:C10000").ClearContents
    son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "D").End(3).Row, s1.Cells(Rows.Count, "F").End(3).Row, s1.Cells(Rows.Count, "G").End(3).Row) + 1
    s1.Range("D2:D" & son).Copy [A2]
    s1.Range("F2:F" & son).Copy [C2]
    s1.Range("G2:G" & son).Copy [B2]
    son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "D").End(3).Row, s2.Cells(Rows.Count, "F").End(3).Row, s2.Cells(Rows.Count, "G").End(3).Row) + 1
    s2.Range("D2:D" & son2).Copy Cells(son2 + 1, "A")
    s2.Range("F2:F" & son2).Copy Cells(son2 + 1, "C")
    s2.Range("G2:G" & son2).Copy Cells(son2 + 1, "B")
    
    enson = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row, Cells(Rows.Count, "C").End(3).Row) + 1
    
    ActiveSheet.Range("$A$1:$C$" & enson).RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
End Sub

Farklı sonuç getirmeyle ilgili olarak dosyanızı görmeden yorum yapamam maalesef. Dosyanıza rapor sayfasından kopya oluşturun, birinde Haluk üstadın, diğerinde Ömer üstadın kodları olsun, öyle paylaşın ki karşılaştırabilelim. Hatta farklı bir sayfada o dosyada asıl olması gereken sonucu manuel olarak düzenlerseniz daha iyi olur.
 
YUSUF44' Alıntı:
Ömer üstadın kodları olsun,
Genişletmek için tıkla ...

Denemeler sırasında dosyayı bozmuşum Aşağıdaki linkten bakabilirsiniz.

Soru - HER İKİ SAYFADA ORTAK OLAN MALZEMELER

Merhabalar, Elimde 900 küsür satır malzeme kodlarının olduğu bir veri sayfası var. Bunların üretim ve satış karşılığını aylara göre ÇOKEĞERSAY ile bulabiliyorum. Burada sorun yok. Ancak raporlama yaparken 900 küsür satır malzeme üzerinde olduğu için pek anlaşılır olmuyor. Filtre seçeneğini...
excel.web.tr excel.web.tr

YUSUF44' Alıntı:
asıl olması gereken sonucu manuel olarak düzenlerseniz daha iyi olur.
Genişletmek için tıkla ...

En başından ne yapmak istediğimi ekte izah etmeye çalıştım. Umarım anlaşılır olmuştur.

Kitap1__-_Kopya.xlsx dosyasını indir - download

Kitap1__-_Kopya.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s7.dosya.tc s7.dosya.tc
 
Gönderdiğiniz dosyada herhangi bir makro yok. Ayrıca istediğim gibi farklı kodların uygulandığı ya da uygulanabileceği şekilde de dosyayı düzenlememişsiniz.

Yine de iki sayfadaki verileri birleştirdikten sonra sıralama yapan kodlar aşağıdaki gibidir:

PHP: 
Private Sub Worksheet_Activate()
    Dim s1 As Worksheet, s2 As Worksheet, Con As Object, RS As Object, SORGU As String

    Set s1 = Sheets("ÜRETİM-VERİ")
    Set s2 = Sheets("SATIS-VERİ")

    Set Con = CreateObject("ADODB.Connection")
    Con.Open "Provider= Microsoft.ACE.OLEDB.12.0; Data Source=" & ThisWorkbook.FullName & ";Extended Properties= 'Excel 12.0; HDR=YES'"

    Range("A5:C10000").ClearContents

    SORGU = " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [ÜRETİM-VERİ$] Where [MALZEME KODU] Is Not Null " & _
            " Union All " & _
            " Select Distinct [GURUP], [MALZEME AÇIKLAMASI], [MALZEME KODU] From [SATIS-VERİ$] Where [MALZEME KODU] Is Not Null"

    Set RS = Con.Execute(SORGU)
    [A5].CopyFromRecordset RS
    enson = WorksheetFunction.Max(2, Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row, Cells(Rows.Count, "C").End(3).Row)
    ActiveWorkbook.Worksheets("MALZEME-AY").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("MALZEME-AY").Sort.SortFields.Add Key:=Range( _
        "A5:A" & enson), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("MALZEME-AY").Sort.SortFields.Add2 Key:=Range( _
        "C5:C" & enson), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("MALZEME-AY").Sort
        .SetRange Range("A5:C" & enson)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Bu arada GURUP'tan kastınız Grup ise dosyanızda Grup olarak kullanmanızı tavsiye ederim. Eğer GURUP'un farklı bir anlamı varsa bu önerimi dikkate almayın lütfen.

Son olarak sıralama yaparken GURUP'a göre ıralandığında 1'den sonra 10'a geçer, 2'ye geçmesini istiyorsanız isimlendirmeyi GURUP-00 formatında yapmalısınız.Yani GURUP-01, GURUP-02 gibi.
 
YUSUF44' Alıntı:
Gönderdiğiniz dosyada herhangi bir makro yok. Ayrıca istediğim gibi farklı kodların uygulandığı ya da uygulanabileceği şekilde de dosyayı düzenlememişsiniz.
Genişletmek için tıkla ...

Merhabalar,

Harici link içeren dosyada istediğiniz gibi ve bizim olmasını istediğimiz gibi düzenlemiştik aslında...

Diğer önerilerinizi dikkate alacağım.

Geriye kalan kısımları fonksiyonlar ile çözmeye çalışacağım.

Bu hali ile tamamdır.

İlginiz ve değerli yardımlarınız için çok teşekkür ederim.

Sağlıcakla kalınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst