Fatura bilgilerini aktarma

halit3 · 15 Temmuz 2016

hesaplama tablosunda sayfasında 3.4.7.8. sıradaki veriler böyle bunları toplayınca sonuç ne olmalıç

3 314654 04.05.2016 A 32676 HALİT ELBİSE 50 ADET 500 40 40 8 400
4 314654 04.05.2016 A 32676 HALİT ELBİSE 18 ADET 180 14,4 10 8 100

7 314655 04.05.2016 A 32676 HALİT ELBİSE 50 ADET 500 40 10 8 100
8 314655 04.05.2016 A 32676 HALİT ELBİSE 18 ADET 180 14,4 8 8 80

halit3 · 15 Temmuz 2016

Birde bu kodu dene

Kod:

Sub kdf_topla2()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set S1 = Sheets("HESAPLAMA TABLOSU") ' veri sayfası
Set S2 = Sheets("YÜKLENİLEN KDV LİSTESİ") 'aktarılan sayfa
'Set S2 = Sheets("YÜKLENİLEN")
S2.Range("b5:o" & Rows.Count).ClearContents 'Clear

S1.Range("G15:G500").Interior.ColorIndex = xlNone
son1 = S1.Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1)

For j = 15 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "f"))
ara2(j) = 1
ara3(j) = WorksheetFunction.Trim(S1.Cells(j, "f")) & WorksheetFunction.Trim(S1.Cells(j, "g")) & WorksheetFunction.Trim(S1.Cells(j, "ı")) & WorksheetFunction.Trim(S1.Cells(j, "j"))
Next j

For m = 15 To son1
aranan3 = ara3(m)

say1 = 0
For t = 15 To son1
If ara3(t) = aranan3 Then
say1 = say1 + 1
If say1 > 1 Then
ara2(t) = 0
S1.Cells(t, 7).Interior.ColorIndex = 8
End If
End If

Next t
Next m

sat1 = 5

For r = 15 To son1
aranan1 = ara1(r)
sut9 = ""
sut10 = ""
sut11 = 0
sut12 = 0
sut16 = 0

If ara2(r) = 1 Then

k = 0
For i = r To son1
If ara2(i) = 1 Then
If ara1(i) = aranan1 Then

k = k + 1

If k = 1 Then
sut9 = S1.Cells(i, 9).Value
sut10 = S1.Cells(i, 10).Value
Else
sut9 = sut9 & "," & S1.Cells(i, 9).Value
sut10 = sut10 & "," & S1.Cells(i, 10).Value
End If

sut11 = sut11 + CDbl(S1.Cells(i, 11).Value)
sut12 = sut12 + CDbl(S1.Cells(i, 12).Value)
sut16 = sut16 + CDbl(S1.Cells(i, 16).Value)
ara2(i) = 0
End If
End If
Next i

S2.Cells(sat1, 2).Value = sat1 - 4
S2.Cells(sat1, 3).Value = S1.Cells(r, 4).Value
S2.Cells(sat1, 4).Value = S1.Cells(r, 5).Value
S2.Cells(sat1, 5).Value = S1.Cells(r, 6).Value
S2.Cells(sat1, 6).Value = S1.Cells(r, 7).Value
S2.Cells(sat1, 7).Value = S1.Cells(r, 8).Value

S2.Cells(sat1, 8).Value = sut9
S2.Cells(sat1, 9).Value = sut10
S2.Cells(sat1, 10).Value = sut11
S2.Cells(sat1, 11).Value = sut12
S2.Cells(sat1, 12).Value = sut16

S2.Cells(sat1, 14).Value = S1.Cells(r, 17).Value
S2.Cells(sat1, 15).Value = S1.Cells(r, 18).Value

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

NADİR YILDIZ · 15 Temmuz 2016

.

halit bey son kodları uyguladım ancak hesaplama tablosundaki mavi ile boyalı alanları listede kendisi otomatik renklendiriyor.ve yüklenilen kdv listesi sayfasına matrah kdv eksik atıyor

halit3 · 15 Temmuz 2016

Ben bir şey anlamıyorum böyle
YÜKLENİLEN KDV LİSTESİ sayfasında hangi sütındaki (isimlere ait) bilgiler eksik geliyor

NADİR YILDIZ · 15 Temmuz 2016

gönderdiğim örneğe baktınızmı..baktıysanız mavi ile işaretli olanlara bakarsanız aktarırken eksik aktarıyor örneğin köseliören firmasına ait fatura matrahı 9.404,58 TL KDV 752,36 TL tutarı yüklenilen kdv listesi sayfasına matrahı 8.323,79 TL kdv 665,90 TL olarak aktarıyor diğerlerinde de aynı sorun var

halit3 · 15 Temmuz 2016

Bunu denermisiniz. fark sadece kırmızı yerdeki sutün indisinde

Kod:

Sub Düğme16_Tıklat()


ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set S1 = Sheets("HESAPLAMA TABLOSU") ' veri sayfası
Set S2 = Sheets("YÜKLENİLEN KDV LİSTESİ") 'aktarılan sayfa
'Set S2 = Sheets("YÜKLENİLEN")
S2.Range("b5:o" & Rows.Count).ClearContents 'Clear

S1.Range("G15:G500").Interior.ColorIndex = xlNone
son1 = S1.Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1)

For j = 15 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "f"))
ara2(j) = 1
ara3(j) = WorksheetFunction.Trim(S1.Cells(j, "f")) & WorksheetFunction.Trim(S1.Cells(j, "g")) & WorksheetFunction.Trim(S1.Cells(j, "ı")) & WorksheetFunction.Trim(S1.Cells(j, [COLOR="Red"]"k"[/COLOR]))
Next j

For m = 15 To son1
aranan3 = ara3(m)

say1 = 0
For t = 15 To son1
If ara3(t) = aranan3 Then
say1 = say1 + 1
If say1 > 1 Then
ara2(t) = 0
S1.Cells(t, 7).Interior.ColorIndex = 8
End If
End If

Next t
Next m

'Exit Sub
sat1 = 5

For r = 15 To son1
aranan1 = ara1(r)
sut9 = ""
sut10 = ""
sut11 = 0
sut12 = 0
sut16 = 0

If ara2(r) = 1 Then

k = 0
For i = r To son1
If ara2(i) = 1 Then
If ara1(i) = aranan1 Then

k = k + 1

If k = 1 Then
sut9 = S1.Cells(i, 9).Value
sut10 = S1.Cells(i, 10).Value
Else
sut9 = sut9 & "," & S1.Cells(i, 9).Value
sut10 = sut10 & "," & S1.Cells(i, 10).Value
End If
sut11 = sut11 + CDbl(S1.Cells(i, 11).Value)
sut12 = sut12 + CDbl(S1.Cells(i, 12).Value)
sut16 = sut16 + CDbl(S1.Cells(i, 16).Value)
ara2(i) = 0
End If
End If
Next i

S2.Cells(sat1, 2).Value = sat1 - 4
S2.Cells(sat1, 3).Value = S1.Cells(r, 4).Value
S2.Cells(sat1, 4).Value = S1.Cells(r, 5).Value
S2.Cells(sat1, 5).Value = S1.Cells(r, 6).Value
S2.Cells(sat1, 6).Value = S1.Cells(r, 7).Value
S2.Cells(sat1, 7).Value = S1.Cells(r, 8).Value

S2.Cells(sat1, 8).Value = sut9
S2.Cells(sat1, 9).Value = sut10
S2.Cells(sat1, 10).Value = sut11
S2.Cells(sat1, 11).Value = sut12
S2.Cells(sat1, 12).Value = sut16

S2.Cells(sat1, 14).Value = S1.Cells(r, 17).Value
S2.Cells(sat1, 15).Value = S1.Cells(r, 18).Value

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

NADİR YILDIZ · 19 Temmuz 2016

.

halit bey yine olmadı..yeşil ile renkli alanların toplamı her ikiside aynı olmalı

halit3 · 19 Temmuz 2016

Neden aynı olacakmış buralar kendi söylediğinizle çelişmiyormusunuz.

örnek olarak HESAPLAMA TABLOSU sayfasında 36 satır ve 300 satırdaki bilgiler aynı değilmi siz bu bilgilerden sadece bir tanesini alacaksınız demiyormusunuz.

Hem aynı olanları aktarmak istemiyorsunuz hemde her iki toplam aynı olsun istiyorsunuz.
nasıl olacak bu iş ?

NADİR YILDIZ · 19 Temmuz 2016

.

özür dilerim. bu örnekteki yeşil alanlar aynı olmak zorunda

halit3 · 19 Temmuz 2016

Herhalde şimdi tamamdır.

Kod:

Sub Düğme16_Tıklat()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set S1 = Sheets("HESAPLAMA TABLOSU") ' veri sayfası
Set S2 = Sheets("YÜKLENİLEN KDV LİSTESİ") 'aktarılan sayfa
'Set S2 = Sheets("YÜKLENİLEN")
S2.Range("b5:o" & Rows.Count).ClearContents 'Clear

S1.Range("G15:G500").Interior.ColorIndex = xlNone
son1 = S1.Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1): ReDim ara4(son1)

For j = 15 To son1
ara1(j) = WorksheetFunction.Trim(S1.Cells(j, "f"))
ara2(j) = 1
ara3(j) = WorksheetFunction.Trim(S1.Cells(j, "f")) & WorksheetFunction.Trim(S1.Cells(j, "g")) & WorksheetFunction.Trim(S1.Cells(j, "ı")) & WorksheetFunction.Trim(S1.Cells(j, "k"))
[COLOR="Red"]ara4(j) = WorksheetFunction.Trim(S1.Cells(j, "P"))[/COLOR]
Next j

For m = 15 To son1
aranan3 = ara3(m)

say1 = 0
For t = 15 To son1

If ara3(t) = aranan3 Then
say1 = say1 + 1
If say1 > 1 Then
ara2(t) = 0
[COLOR="red"]ara4(m) = ara4(m) + CDbl(ara4(t))[/COLOR]
S1.Cells(t, 7).Interior.ColorIndex = 8
End If
End If

Next t
Next m

sat1 = 5

For r = 15 To son1
aranan1 = ara1(r)
sut9 = ""
sut10 = ""
sut11 = 0
sut12 = 0
sut16 = 0
sut17 = 0

If ara2(r) = 1 Then

k = 0
For i = r To son1
If ara2(i) = 1 Then

If ara1(i) = aranan1 Then
k = k + 1
If k = 1 Then
sut9 = S1.Cells(i, 9).Value
sut10 = S1.Cells(i, 10).Value
Else
sut9 = sut9 & "," & S1.Cells(i, 9).Value
sut10 = sut10 & "," & S1.Cells(i, 10).Value
End If

sut11 = sut11 + CDbl(S1.Cells(i, 11).Value)
sut12 = sut12 + CDbl(S1.Cells(i, 12).Value)
'sut16 = sut16 + CDbl(S1.Cells(i, 16).Value)
[COLOR="red"]sut16 = sut16 + CDbl(ara4(i))[/COLOR]
ara2(i) = 0

End If

End If


Next i

S2.Cells(sat1, 2).Value = sat1 - 4
S2.Cells(sat1, 3).Value = S1.Cells(r, 4).Value
S2.Cells(sat1, 4).Value = S1.Cells(r, 5).Value
S2.Cells(sat1, 5).Value = S1.Cells(r, 6).Value
S2.Cells(sat1, 6).Value = S1.Cells(r, 7).Value
S2.Cells(sat1, 7).Value = S1.Cells(r, 8).Value

S2.Cells(sat1, 8).Value = sut9
S2.Cells(sat1, 9).Value = sut10
S2.Cells(sat1, 10).Value = sut11
S2.Cells(sat1, 11).Value = sut12
S2.Cells(sat1, 12).Value = sut16

S2.Cells(sat1, 14).Value = S1.Cells(r, 17).Value
S2.Cells(sat1, 15).Value = S1.Cells(r, 18).Value

sat1 = sat1 + 1

End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

NADİR YILDIZ · 19 Temmuz 2016

Valla halit bey ne kadar teşekkür etsem azdır.sonunda oldu sizi çok uğraştırdım hakkını helal et..bu arada ilginç olmakla beraber merak ettiğim 753 kişi görünteleme yapmasına rağmen sizden başka cevap veren olmadı..ama siz ısrarla çözüme ulaştınız..çok çok teşekkür ederim...hayırlı günler dilerim size..

halit3 · 19 Temmuz 2016

İyi çalışmalar

fundatopcu · 6 Şubat 2017

tablonun son halini atabilir misiniz?
İncelemek isterim.

Fatura bilgilerini aktarma

halit3

Uzman

halit3

Uzman

NADİR YILDIZ

Ekli dosyalar

halit3

Uzman

NADİR YILDIZ

halit3

Uzman

NADİR YILDIZ

Ekli dosyalar

halit3

Uzman

NADİR YILDIZ

Ekli dosyalar

halit3

Uzman

NADİR YILDIZ

halit3

Uzman

fundatopcu