• DİKKAT

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

Yinelenen Seri no hk.

1

1903emre34@gmail.com

Altın Üye
Katılım
29 Mayıs 2016
Mesajlar
946
Excel Vers. ve Dili
Microsoft Excel 2013 Türkçe
Merhaba,

Alış faturasının seri no kısmının altında numaraları alt alta aynı devam etmektedir, benim istediğim tek seri numarada ve alınan mal, alınan mal ve/veya hizmetin mikarı, kdv hariç toplamı alınması, istenen sayfa2'de yapılmıştır. aşağıda kod forumda buldum bu konuyla ilgili, hata verdi.


http://www.dosya.tc/server10/w1h99j/seri_no.zip.html

Kod: 
Sub fatura()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

    son1 = s1.Cells(Rows.Count, "B").End(3).Row

    s1.Select
    s1.Columns("B:B").Select
    Selection.Copy
    s2.Select
    s2.[B1].Select
    ActiveSheet.Paste
    s2.[B1].Select
    Application.CutCopyMode = False
    son2 = s2.Cells(Rows.Count, "B").End(3).Row
    s2.Range("$A$1:$L$" & son1).RemoveDuplicates Columns:=2, Header:=xlYes
    son3 = s2.Cells(Rows.Count, "B").End(3).Row
    
    For i = 2 To son3
        s2.Cells(i, "C") = WorksheetFunction.VLookup(s2.Cells(i, "B"), s1.Range("$B$1:$L$" & son1), 2, 0)
        s2.Cells(i, "D") = WorksheetFunction.VLookup(s2.Cells(i, "B"), s1.Range("$B$1:$L$" & son1), 3, 0)
        s2.Cells(i, "E") = WorksheetFunction.VLookup(s2.Cells(i, "B"), s1.Range("$B$1:$L$" & son1), 4, 0)
        s2.Cells(i, "F") = WorksheetFunction.VLookup(s2.Cells(i, "B"), s1.Range("$B$1:$L$" & son1), 5, 0)
        s2.Cells(i, "G") = WorksheetFunction.SumIf(s1.Range("$B$1:$B$" & son1), s2.Cells(i, "B"), s1.Range("$G$1:$G$" & son1))
        s2.Cells(i, "H") = WorksheetFunction.VLookup(s2.Cells(i, "B"), s1.Range("$B$1:$L$" & son1), 7, 0)
        s2.Cells(i, "I") = WorksheetFunction.SumIf(s1.Range("$B$1:$B$" & son1), s2.Cells(i, "B"), s1.Range("$I$1:$I$" & son1))
        s2.Cells(i, "K") = WorksheetFunction.SumIf(s1.Range("$B$1:$B$" & son1), s2.Cells(i, "B"), s1.Range("$K$1:$K$" & son1))
    Next

End Sub
 
Merhaba
Aşağıdaki "Sayfa1" de çok fazla dolu satır yoksa aşağıdaki gibi deneyebilirsiniz.
Kod: 
[SIZE="2"]Sub fatura()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, x As Integer
Dim a As Long, b As Long, j As Long, j2 As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Activate
s2.Range("B4:L" & Rows.Count) = Empty
i = 4: x = 4
j = s1.Cells(Rows.Count, "D").End(3).Row
For a = i To j
j2 = s2.Cells(Rows.Count, "D").End(3).Row
If WorksheetFunction.CountIf(s2.Range("D4:D" & j2), s1.Cells(a, "D")) = 0 Then
s1.Range("B" & a & ":L" & a).Copy s2.Range("B" & j2 + 1)
   's2.Range("B" & j2 + 1 & ":L" & j2 + 1).Value = s1.Range("B" & a & ":L" & a).Value
If a = j Then Exit For
For b = a + 1 To j
If Trim(s1.Cells(a, "D")) = Trim(s1.Cells(b, "D")) Then
s2.Range("G" & j2 + 1) = s2.Range("G" & j2 + 1) + s1.Range("G" & b)
s2.Range("H" & j2 + 1) = s2.Range("H" & j2 + 1) + s1.Range("H" & b)
s2.Range("I" & j2 + 1) = s2.Range("I" & j2 + 1) + s1.Range("I" & b)
s2.Range("J" & j2 + 1) = s2.Range("J" & j2 + 1) + s1.Range("J" & b)
End If
Next
End If
Next
End Sub [/SIZE]
 
Merhaba,

Üstad, "sayfa1'de satır 1500 kadar uzanıyor, kodu çalıştırdığım zaman toplamları (benim istediğim yapıyor) ama en sonunda Run-Tıme error 13 Type mısmatch hatası veriyor
 
"Sayfa1" de toplanan hücrelerde numeric olmayan hücre varsa; döngü bölümünü aşağıdaki gibi değişip denermisiniz?
Kod: 
[SIZE="2"]sub fatura()
'....
'...
For b = a + 1 To j
If Trim(s1.Cells(a, "D")) = Trim(s1.Cells(b, "D")) Then
If IsNumeric(s1.Range("G" & b)) = True Then _
s2.Range("G" & j2 + 1) = s2.Range("G" & j2 + 1) + s1.Range("G" & b)
If IsNumeric(s1.Range("H" & b)) = True Then _
s2.Range("H" & j2 + 1) = s2.Range("H" & j2 + 1) + s1.Range("H" & b)
If IsNumeric(s1.Range("I" & b)) = True Then _
s2.Range("I" & j2 + 1) = s2.Range("I" & j2 + 1) + s1.Range("I" & b)
If IsNumeric(s1.Range("J" & b)) = True Then _
s2.Range("J" & j2 + 1) = s2.Range("J" & j2 + 1) + s1.Range("J" & b)
End If
Next
End If
Next
End Sub

 [/SIZE]
 
Kod: 
Sub fatura()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, x As Integer
Dim a As Long, b As Long, j As Long, j2 As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Activate
s2.Range("B4:L" & Rows.Count) = Empty
i = 4: x = 4
j = s1.Cells(Rows.Count, "D").End(3).Row
For b = a + 1 To j
If Trim(s1.Cells(a, "D")) = Trim(s1.Cells(b, "D")) Then
If IsNumeric(s1.Range("G" & b)) = True Then _
s2.Range("G" & j2 + 1) = s2.Range("G" & j2 + 1) + s1.Range("G" & b)
If IsNumeric(s1.Range("H" & b)) = True Then _
s2.Range("H" & j2 + 1) = s2.Range("H" & j2 + 1) + s1.Range("H" & b)
If IsNumeric(s1.Range("I" & b)) = True Then _
s2.Range("I" & j2 + 1) = s2.Range("I" & j2 + 1) + s1.Range("I" & b)
If IsNumeric(s1.Range("J" & b)) = True Then _
s2.Range("J" & j2 + 1) = s2.Range("J" & j2 + 1) + s1.Range("J" & b)
End If


Next
End If
Next
End Sub

End ıf hatası verdi,
 
Son döngü değişecekti
Kodları komple kopyalayıp değiştirelim
Kod: 
 [SIZE="2"]Sub fatura()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, x As Integer
Dim a As Long, b As Long, j As Long, j2 As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Activate
s2.Range("B4:L" & Rows.Count) = Empty
i = 4: x = 4
j = s1.Cells(Rows.Count, "D").End(3).Row
For a = i To j
j2 = s2.Cells(Rows.Count, "D").End(3).Row
If WorksheetFunction.CountIf(s2.Range("D4:D" & j2), s1.Cells(a, "D")) = 0 Then
s1.Range("B" & a & ":L" & a).Copy s2.Range("B" & j2 + 1)
   's2.Range("B" & j2 + 1 & ":L" & j2 + 1).Value = s1.Range("B" & a & ":L" & a).Value
If a = j Then Exit For
For b = a + 1 To j
If Trim(s1.Cells(a, "D")) = Trim(s1.Cells(b, "D")) Then
If IsNumeric(s1.Range("G" & b)) = True Then _
s2.Range("G" & j2 + 1) = s2.Range("G" & j2 + 1) + s1.Range("G" & b)
If IsNumeric(s1.Range("H" & b)) = True Then _
s2.Range("H" & j2 + 1) = s2.Range("H" & j2 + 1) + s1.Range("H" & b)
If IsNumeric(s1.Range("I" & b)) = True Then _
s2.Range("I" & j2 + 1) = s2.Range("I" & j2 + 1) + s1.Range("I" & b)
If IsNumeric(s1.Range("J" & b)) = True Then _
s2.Range("J" & j2 + 1) = s2.Range("J" & j2 + 1) + s1.Range("J" & b)
End If
Next
End If
Next
End Sub [/SIZE]
 
Ustad, teşekkürler

original dosya uyguladım oldu, yalnız "G" sütunda, (bazı sütünlarda) 1.11111E+11 bazen belirtiğim şekilde çıkıyor,
 
1903emre34@gmail.com' Alıntı:
Ustad, teşekkürler
original dosya uyguladım oldu, yalnız "G" sütunda, (bazı sütünlarda) 1.11111E+11 bazen belirtiğim şekilde çıkıyor,
Genişletmek için tıkla ...
"Metin olarak saklanan" sayı varsa;
Kodlardaki "G" sütununa toplam alan şu satırın eşitliğini aşağıdaki gibi değişelim.
Kod: 
[SIZE="2"]If IsNumeric(s1.Range("G" & b)) = True Then _
s2.Range("G" & j2 + 1) = [COLOR="Red"]CDbl(s2.Range("G" & j2 + 1)) + CDbl(s1.Range("G" & b))[/COLOR] [/SIZE]
 
Değişmedi, kullandığım kodlar; gözümden kaçırdığım?

Kod: 
 Sub fatura()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, x As Integer
Dim a As Long, b As Long, j As Long, j2 As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Activate
s2.Range("B4:L" & Rows.Count) = Empty
i = 4: x = 4
j = s1.Cells(Rows.Count, "D").End(3).Row
For a = i To j
j2 = s2.Cells(Rows.Count, "D").End(3).Row
If WorksheetFunction.CountIf(s2.Range("D4:D" & j2), s1.Cells(a, "D")) = 0 Then
s1.Range("B" & a & ":L" & a).Copy s2.Range("B" & j2 + 1)
   's2.Range("B" & j2 + 1 & ":L" & j2 + 1).Value = s1.Range("B" & a & ":L" & a).Value
If a = j Then Exit For
For b = a + 1 To j
If Trim(s1.Cells(a, "D")) = Trim(s1.Cells(b, "D")) Then
If IsNumeric(s1.Range("G" & b)) = True Then _
s2.Range("G" & j2 + 1) = CDbl(s2.Range("G" & j2 + 1)) + CDbl(s1.Range("G" & b))
If IsNumeric(s1.Range("H" & b)) = True Then _
s2.Range("H" & j2 + 1) = s2.Range("H" & j2 + 1) + s1.Range("H" & b)
If IsNumeric(s1.Range("I" & b)) = True Then _
s2.Range("I" & j2 + 1) = s2.Range("I" & j2 + 1) + s1.Range("I" & b)
If IsNumeric(s1.Range("J" & b)) = True Then _
s2.Range("J" & j2 + 1) = s2.Range("J" & j2 + 1) + s1.Range("J" & b)
End If
Next
End If
Next
End Sub
 
1903emre34@gmail.com' Alıntı:
Değişmedi, kullandığım kodlar; gözümden kaçırdığım?
Genişletmek için tıkla ...
Kodlarda eksiklik görünmüyor
Yukarıdaki kodlar tek döngü ile aşağıdaki gibide olabilir
Kod: 
[SIZE="2"]Sub fatura()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, x As Integer
Dim a As Long, b As Long, j As Long, j2 As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Activate
s2.Range("B4:L" & Rows.Count) = Empty
i = 4: x = 4
j = s1.Cells(Rows.Count, "D").End(3).Row
For a = i To j
j2 = s2.Cells(Rows.Count, "D").End(3).Row
If WorksheetFunction.CountIf(s2.Range("D4:D" & j2), s1.Cells(a, "D")) = 0 Then
s1.Range("B" & a & ":L" & a).Copy s2.Range("B" & j2 + 1)
s2.Cells(j2 + 1, "G") = WorksheetFunction.SumIf(s1.Range("$D$4:$D$" & j), s2.Cells(j2 + 1, "D"), s1.Range("$G$4:$G$" & j))
s2.Cells(j2 + 1, "H") = WorksheetFunction.SumIf(s1.Range("$D$4:$D$" & j), s2.Cells(j2 + 1, "D"), s1.Range("$H$4:$H$" & j))
s2.Cells(j2 + 1, "I") = WorksheetFunction.SumIf(s1.Range("$D$4:$D$" & j), s2.Cells(j2 + 1, "D"), s1.Range("$I$4:$I$" & j))
s2.Cells(j2 + 1, "J") = WorksheetFunction.SumIf(s1.Range("$D$4:$D$" & j), s2.Cells(j2 + 1, "D"), s1.Range("$J$4:$J$" & j))
End If
Next
End Sub [/SIZE]
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst