NADİR YILDIZ
Altın Üye
- Katılım
- 7 Ocak 2006
- Mesajlar
- 1,378
- Excel Vers. ve Dili
- 2016 Türkçe
- Altın Üyelik Bitiş Tarihi
- 09-02-2026
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
" & 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"))
ara4(j) = WorksheetFunction.Trim(S1.Cells(j, "P"))
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
ara4(m) = ara4(m) + CDbl(ara4(t))
S1.Cells(t, 7).Interior.ColorIndex = 0
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)
sut16 = sut16 + CDbl(ara4(i))
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
bu makro kodu ile hesaplama tablosundaki aynı ft ları yüklenilen kdv listesi sayfasına aktarım yapıyordum ancak makro tuşuna bastığımda resimdeki gibi hata veriyor nereden kaynaklı olabilir..dosyayı ekleyemiyorum çok sayıda özel bilgi içeriyor.
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
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"))
ara4(j) = WorksheetFunction.Trim(S1.Cells(j, "P"))
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
ara4(m) = ara4(m) + CDbl(ara4(t))
S1.Cells(t, 7).Interior.ColorIndex = 0
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)
sut16 = sut16 + CDbl(ara4(i))
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
bu makro kodu ile hesaplama tablosundaki aynı ft ları yüklenilen kdv listesi sayfasına aktarım yapıyordum ancak makro tuşuna bastığımda resimdeki gibi hata veriyor nereden kaynaklı olabilir..dosyayı ekleyemiyorum çok sayıda özel bilgi içeriyor.
Ekli dosyalar
-
89.3 KB Görüntüleme: 6