• DİKKAT

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

Düşeyara Sanırım

  • Konbuyu başlatan Konbuyu başlatan ERRİC
  • Başlangıç tarihi Başlangıç tarihi
E

ERRİC

Altın Üye
Katılım
19 Ekim 2010
Mesajlar
313
Excel Vers. ve Dili
OFFİCE 2009
Selamlar ekteki dosyamda bir form doldurmam lazım uzunca veri sayfasından alacak verileri ; manuel olarak kendim formul ile yapıyorum ama Sayfa 1 'e verileri fatura numarasını alarak getirebilirmi umarım yeterince açık olmuştur özellikle şu birden fazla kalem olan faturalardaki stok adları ve miktarlarının birleştirilmesi önemli sanırım çünkü bazı faturalar tek kalem bazıları birden fazla

Saygılar
 

Ekli dosyalar

. . .

Dosyanız ektedir.


...::: Ekli Dosyayı İndirmek İçin Linki Tıklayınız :::...
http://yadi.sk/d/U0mUCeTzK2Ni3
Genişletmek için tıkla ...

Kod: 
Sub KOD()
    Application.ScreenUpdating = False

    Dim S1     As Worksheet
    Dim S2     As Worksheet
    Dim i      As Integer
    Dim sat    As Integer
    Dim Sisim  As String
    Dim Smiktar As String
    Dim ara

    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("veri")
    sat = 2
    S1.Range("A2:M65536").ClearContents
    For i = 2 To S2.[B65536].End(3).Row
        If WorksheetFunction.CountIf(S2.Range("B2:B" & i), S2.Cells(i, "B")) = 1 Then
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = S2.Cells(i, "A")
            S1.Cells(sat, "D") = S2.Cells(i, "B")
            S1.Cells(sat, "E") = S2.Cells(i, "D")
            S1.Cells(sat, "F") = S2.Cells(i, "J")
            S1.Cells(sat, "L") = S2.Cells(i, "K")
            If WorksheetFunction.CountIf(S2.Range("B2:B65536"), S2.Cells(i, "B")) = 1 Then
                S1.Cells(sat, "G") = S2.Cells(i, "F")
                S1.Cells(sat, "H") = S2.Cells(i, "G")
                S1.Cells(sat, "I") = S2.Cells(i, "L")
                S1.Cells(sat, "J") = S2.Cells(i, "M")
                sat = sat + 1
            Else
                Set ara = S2.Range("B2:B65536").Find(S2.Cells(i, "B"), , xlValues, xlWhole)
                If Not ara Is Nothing Then
                    adres = ara.Address
                    Do
                        Sisim = Sisim & S2.Cells(ara.Row, "F") & ","
                        Smiktar = Smiktar & S2.Cells(ara.Row, "G") & ","
                        Set ara = S2.Range("B2:B65536").FindNext(ara)
                    Loop While Not ara Is Nothing And ara.Address <> adres
                    S1.Cells(sat, "G") = Sisim
                    S1.Cells(sat, "H") = Smiktar
                    S1.Cells(sat, "I") = WorksheetFunction.SumIf(S2.Range("B2:B65536"), S2.Cells(i, "B"), S2.Range("L2:L65536"))
                    S1.Cells(sat, "J") = WorksheetFunction.SumIf(S2.Range("B2:B65536"), S2.Cells(i, "B"), S2.Range("M2:M65536"))
                    sat = sat + 1
                    Sisim = Empty
                    Smiktar = Empty
                End If

            End If
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub


. . .
 

Ekli dosyalar

Son düzenleme:
Hüseyin bey Elinize Emeğinize Sağlık çok Teşekkür ederim Harikasınız !

Ne kadar teşekkür etsem Ne kadar dua etsem azdır

İyi Akşamlar

Saygılar.
 
hüseyin çoban' Alıntı:
. . .

Dosyanız ektedir.




Kod: 
sub kod()
    application.screenupdating = false

    dim s1     as worksheet
    dim s2     as worksheet
    dim i      as ınteger
    dim sat    as ınteger
    dim sisim  as string
    dim smiktar as string
    dim ara

    set s1 = sheets("sayfa1")
    set s2 = sheets("veri")
    sat = 2
    s1.range("a2:m65536").clearcontents
    for i = 2 to s2.[b65536].end(3).row
        ıf worksheetfunction.countıf(s2.range("b2:b" & i), s2.cells(i, "b")) = 1 then
            s1.cells(sat, "a") = sat - 1
            s1.cells(sat, "b") = s2.cells(i, "a")
            s1.cells(sat, "d") = s2.cells(i, "b")
            s1.cells(sat, "e") = s2.cells(i, "d")
            s1.cells(sat, "f") = s2.cells(i, "j")
            s1.cells(sat, "l") = s2.cells(i, "k")
            ıf worksheetfunction.countıf(s2.range("b2:b65536"), s2.cells(i, "b")) = 1 then
                s1.cells(sat, "g") = s2.cells(i, "f")
                s1.cells(sat, "h") = s2.cells(i, "g")
                s1.cells(sat, "ı") = s2.cells(i, "l")
                s1.cells(sat, "j") = s2.cells(i, "m")
                sat = sat + 1
            else
                set ara = s2.range("b2:b65536").find(s2.cells(i, "b"), , xlvalues, xlwhole)
                ıf not ara ıs nothing then
                    adres = ara.address
                    do
                        sisim = sisim & s2.cells(ara.row, "f") & ","
                        smiktar = smiktar & s2.cells(ara.row, "g") & ","
                        set ara = s2.range("b2:b65536").findnext(ara)
                    loop while not ara ıs nothing and ara.address <> adres
                    s1.cells(sat, "g") = sisim
                    s1.cells(sat, "h") = smiktar
                    s1.cells(sat, "ı") = worksheetfunction.sumıf(s2.range("b2:b65536"), s2.cells(i, "b"), s2.range("l2:l65536"))
                    s1.cells(sat, "j") = worksheetfunction.sumıf(s2.range("b2:b65536"), s2.cells(i, "b"), s2.range("m2:m65536"))
                    sat = sat + 1
                    sisim = empty
                    smiktar = empty
                end ıf

            end ıf
        end ıf
    next i
    application.screenupdating = true
    msgbox " b i t t i "
end sub


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

dosyanın yeni hali ekte rica etsem bakabilir misiniz bir kaç sutun ekledim sadece o kadar revize eder misiniz lütfen
 

Ekli dosyalar

. . .
Kod: 
Sub KOD()
    Application.ScreenUpdating = False

    Dim S1     As Worksheet
    Dim S2     As Worksheet
    Dim i      As Integer
    Dim sat    As Integer
    Dim Sisim  As String
    Dim Smiktar As String
    Dim ara

    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("veri")
    sat = 2
    S1.Range("A2:M65536").ClearContents
    For i = 2 To S2.[C65536].End(3).Row
        If WorksheetFunction.CountIf(S2.Range("C2:C" & i), S2.Cells(i, "C")) = 1 Then
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = S2.Cells(i, "A")
            S1.Cells(sat, "C") = S2.Cells(i, "B")
            S1.Cells(sat, "D") = S2.Cells(i, "C")
            S1.Cells(sat, "E") = S2.Cells(i, "E")
            S1.Cells(sat, "F") = S2.Cells(i, "K")
            S1.Cells(sat, "L") = S2.Cells(i, "L")
            If WorksheetFunction.CountIf(S2.Range("C2:C65536"), S2.Cells(i, "C")) = 1 Then
                S1.Cells(sat, "G") = S2.Cells(i, "G")
                S1.Cells(sat, "H") = S2.Cells(i, "H") & " " & S2.Cells(i, "P")
                S1.Cells(sat, "I") = S2.Cells(i, "M")
                S1.Cells(sat, "J") = S2.Cells(i, "N")
                sat = sat + 1
            Else
                Set ara = S2.Range("C2:C65536").Find(S2.Cells(i, "C"), , xlValues, xlWhole)
                If Not ara Is Nothing Then
                    adres = ara.Address
                    Do
                        Sisim = Sisim & S2.Cells(ara.Row, "G") & ","
                        Smiktar = Smiktar & S2.Cells(ara.Row, "H") & " " & S2.Cells(ara.Row, "P") & ","
                        Set ara = S2.Range("C2:C65536").FindNext(ara)
                    Loop While Not ara Is Nothing And ara.Address <> adres
                    S1.Cells(sat, "G") = Sisim
                    S1.Cells(sat, "H") = Smiktar
                    S1.Cells(sat, "I") = WorksheetFunction.SumIf(S2.Range("C2:C65536"), S2.Cells(i, "C"), S2.Range("M2:M65536"))
                    S1.Cells(sat, "J") = WorksheetFunction.SumIf(S2.Range("C2:C65536"), S2.Cells(i, "C"), S2.Range("N2:N65536"))
                    sat = sat + 1
                    Sisim = Empty
                    Smiktar = Empty
                End If

            End If
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

Düzeltme: #6 nolu mesaja göre revize edildi.

. . .
 
Son düzenleme:
Hüseyin Çoban' Alıntı:
. . .

Birim ve seri ilaveleri için şu kısımlar tabloya göre değiştirin.
Kodlarda sütunlar açıkca görünüyor. Kodları yazdırarak yeni tabloya göre üzerinde değiştirin, daha sonra kodlarıda değiştirerek deneyiniz.

Kod: 
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = S2.Cells(i, "A")
  [COLOR="Red"]          S1.Cells(sat, "Sayfa1 ilgili sütun") = S2.Cells(i, "A") ' SERİ İÇİN[/COLOR]
            S1.Cells(sat, "D") = S2.Cells(i, "B")
            S1.Cells(sat, "E") = S2.Cells(i, "D")
            S1.Cells(sat, "F") = S2.Cells(i, "J")
            S1.Cells(sat, "L") = S2.Cells(i, "K")
            If WorksheetFunction.CountIf(S2.Range("B2:B65536"), S2.Cells(i, "B")) = 1 Then
                S1.Cells(sat, "G") = S2.Cells(i, "F")
         [COLOR="Red"]       S1.Cells(sat, "H") = S2.Cells(i, "G") & S2.Cells(i, "birimin bulunduğu sütun")[/COLOR]
                S1.Cells(sat, "I") = S2.Cells(i, "L")
                S1.Cells(sat, "J") = S2.Cells(i, "M")
                sat = sat + 1
            Else
                Set ara = S2.Range("B2:B65536").Find(S2.Cells(i, "B"), , xlValues, xlWhole)
                If Not ara Is Nothing Then
                    adres = ara.Address
                    Do
                        Sisim = Sisim & S2.Cells(ara.Row, "F") & ","
[COLOR="Red"]                        Smiktar = Smiktar & S2.Cells(ara.Row, "G") & S2.Cells(ara.Row, "birimin bulunduğu sütun") & ","[/COLOR]
                        Set ara = S2.Range("B2:B65536").FindNext(ara)
                    Loop While Not ara Is Nothing And ara.Address <> adres

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

HÜSEYİN BEY yapmaya çalıştım ama ekte gördüğünüz gibi bazı yerlerin tümünü topluyor bakar mısınız lütfen
 

Ekli dosyalar

Hüseyin Çoban' Alıntı:
. . .
Kod: 
Sub KOD()
    Application.ScreenUpdating = False

    Dim S1     As Worksheet
    Dim S2     As Worksheet
    Dim i      As Integer
    Dim sat    As Integer
    Dim Sisim  As String
    Dim Smiktar As String
    Dim ara

    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("veri")
    sat = 2
    S1.Range("A2:M65536").ClearContents
    For i = 2 To S2.[C65536].End(3).Row
        If WorksheetFunction.CountIf(S2.Range("C2:C" & i), S2.Cells(i, "C")) = 1 Then
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = S2.Cells(i, "A")
            S1.Cells(sat, "C") = S2.Cells(i, "B")
            S1.Cells(sat, "D") = S2.Cells(i, "C")
            S1.Cells(sat, "E") = S2.Cells(i, "E")
            S1.Cells(sat, "F") = S2.Cells(i, "K")
            S1.Cells(sat, "L") = S2.Cells(i, "L")
            If WorksheetFunction.CountIf(S2.Range("C2:C65536"), S2.Cells(i, "C")) = 1 Then
                S1.Cells(sat, "G") = S2.Cells(i, "G")
                S1.Cells(sat, "H") = S2.Cells(i, "H") & " " & S2.Cells(i, "P")
                S1.Cells(sat, "I") = S2.Cells(i, "M")
                S1.Cells(sat, "J") = S2.Cells(i, "N")
                sat = sat + 1
            Else
                Set ara = S2.Range("C2:C65536").Find(S2.Cells(i, "C"), , xlValues, xlWhole)
                If Not ara Is Nothing Then
                    adres = ara.Address
                    Do
                        Sisim = Sisim & S2.Cells(ara.Row, "G") & ","
                        Smiktar = Smiktar & S2.Cells(ara.Row, "H") & " " & S2.Cells(ara.Row, "P") & ","
                        Set ara = S2.Range("C2:C65536").FindNext(ara)
                    Loop While Not ara Is Nothing And ara.Address <> adres
                    S1.Cells(sat, "G") = Sisim
                    S1.Cells(sat, "H") = Smiktar
                    S1.Cells(sat, "I") = WorksheetFunction.SumIf(S2.Range("C2:C65536"), S2.Cells(i, "C"), S2.Range("M2:M65536"))
                    S1.Cells(sat, "J") = WorksheetFunction.SumIf(S2.Range("C2:C65536"), S2.Cells(i, "C"), S2.Range("N2:N65536"))
                    sat = sat + 1
                    Sisim = Empty
                    Smiktar = Empty
                End If

            End If
        End If
    Next i
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

Düzeltme: #6 nolu mesaja göre revize edildi.

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

Elinize Sağlık İyi Haftalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst