Başka çalışma kitabına aktarsın?

E

Ercan_ÇELİKOĞLU

Katılım
5 Nisan 2007
Mesajlar
409
Excel Vers. ve Dili
excel 2010 tr
Ekte gönderdiğim dosyada açıklama mevcut elimde şu kodlar var asıl çalıştığım programın kodları örnek dosyaya nasıl dizayn edebilirim.
Sub RaporAl()
Dim wb As Workbook
Dim sh As Worksheet
Dim shA As Worksheet
Dim basliklar As Variant
Dim i%, y%, Ay%, Yil%, x%, j%
Dim Ay1 As String
Dim Tarih As Date
Dim arrVeri() As Variant
Dim arrVeriAna() As Variant
Dim bul As Range
Dim adres As String
Dim toplam1 As Currency, toplam2 As Currency, toplam3 As Currency, toplam4 As Currency, toplam5 As Currency, toplam As Currency
Set shC = ThisWorkbook.Sheets("Cocuk")
Set shV = ThisWorkbook.Sheets("Veli")
Set shK = ThisWorkbook.Sheets("Katsayi")
Set shA = ThisWorkbook.Sheets("AnaSayfa")
Set shS = ThisWorkbook.Sheets("Sube")

Ay = Sheets("AnaSayfa").ComboBox1.ListIndex + 1
Ay1 = Sheets("AnaSayfa").ComboBox1
Yil = Sheets("AnaSayfa").TextBox1
Tarih = CDate("01." & Ay & "." & Yil)
If Sheets("AnaSayfa").ListBox1.ListIndex = 0 Then
For i = 2 To shC.Cells(65536, 1).End(xlUp).Row
If Tarih >= shC.Cells(i, 13) And Tarih <= shC.Cells(i, 14) Or shC.Cells(i, 6) = True Then: x = x + 1
Next i
ReDim arrVeri(1 To x + 1, 1 To 19)
For i = 2 To shC.Cells(65536, 1).End(xlUp).Row
If shC.Cells(i, 15) = False And Tarih >= shC.Cells(i, 13) And Tarih <= shC.Cells(i, 14) Or shC.Cells(i, 6) = True Then
y = y + 1
arrVeri(y, 1) = y
arrVeri(y, 2) = shC.Cells(i, 3)
arrVeri(y, 3) = shC.Cells(i, 4)
arrVeri(y, 4) = shC.Cells(i, 5)
arrVeri(y, 5) = Application.WorksheetFunction.VLookup(shC.Cells(i, 2), shV.Range("A1:E" & shV.Cells(65536, 1).End(xlUp).Row), 2, False) & " " _
& Application.WorksheetFunction.VLookup(shC.Cells(i, 2), shV.Range("A1:E" & shV.Cells(65536, 1).End(xlUp).Row), 3, False)
arrVeri(y, 6) = IIf(shC.Cells(i, 6) = True, "Eve Dönüş", "")
If shC.Cells(i, 7) = True Then
arrVeri(y, 7) = "İlkÖğretim Harçlığı"
ElseIf shC.Cells(i, 8) = True Then
arrVeri(y, 7) = "Lise Harçlığı"
Else
arrVeri(y, 7) = ""
End If
arrVeri(y, 8) = shC.Cells(i, 13)
arrVeri(y, 9) = shC.Cells(i, 14)
arrVeri(y, 10) = 1
arrVeri(y, 11) = 1
arrVeri(y, 12) = FormatNumber(shC.Cells(i, 7) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 6) + shC.Cells(i, 8) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 7), 2) * (-1)
If Ay = 1 Or Ay = 8 Then
arrVeri(y, 13) = FormatNumber(shC.Cells(i, 9) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * (shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5), 2) * (-1)
Else
arrVeri(y, 13) = 0
End If
If Ay = 4 Or Ay = 9 Then
arrVeri(y, 14) = FormatNumber(shC.Cells(i, 10) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * (shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5), 2) * (-1)
Else
arrVeri(y, 14) = 0
End If
arrVeri(y, 15) = "" 'Yol gideri belli değil, elle girilecek
arrVeri(y, 16) = FormatNumber(shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * (shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5), 2) * 1
arrVeri(y, 17) = arrVeri(y, 12) + arrVeri(y, 13) + arrVeri(y, 14) + arrVeri(y, 16)
arrVeri(y, 18) = Application.WorksheetFunction.VLookup(Application.WorksheetFunction.VLookup(shC.Cells(i, 2), shV.Range("A1:E" & shV.Cells(65536, 1).End(xlUp).Row), 4, False), shS.Range("A2:D" & shS.Cells(65536, 1).End(xlUp).Row), 3, False)
arrVeri(y, 19) = Application.WorksheetFunction.VLookup(shC.Cells(i, 2), shV.Range("A1:E" & shV.Cells(65536, 1).End(xlUp).Row), 5, False)
End If
Next i
Set wb = Workbooks.Add
Set sh = wb.Sheets(1)
ActiveWindow.DisplayGridlines = False
basliklar = Array("No", "Adı", "Soyadı", "Nesi", "Velisi", "Durum", _
"Açıklama", "Başl.Ay", "Bitiş Ayı", "Ay", _
"Kişi", "Harçlık", "Okul Yrd", "Giyim Yrd", _
"Yol Gdr", "Yardım Mik", "Top.Ödenek", _
"Şube", "Hesap No")
sh.Cells(4, 2).Resize(, 19) = basliklar
sh.Cells(5, 2).Resize(y, 19) = arrVeri
sh.Rows(4).Font.Bold = True
sh.Range("I5:J" & sh.Cells(65536, 2).End(xlUp).Row).NumberFormat = "mmm-yy"
sh.Columns("B:U").EntireColumn.AutoFit
sh.Cells(2, 2) = UCase(Ay1) & " " & Yil & " Ayı"
sh.Cells(3, 2) = "NAKDİ YARDIM BORDROSU"
sh.Cells(2, 20) = "Bütçe Yılı : " & Yil
sh.Cells(3, 20) = "Ait Olduğu Ay : " & Ay1
sh.Range(sh.Cells(2, 20), sh.Cells(3, 20)).HorizontalAlignment = xlRight
sh.Cells(y + 5, 10) = "Genel Toplam"
sh.Cells(y + 5, 18).Formula = "=SUM(R5:R" & y + 4 & ")"
sh.Rows(y + 5).Font.Bold = True
sh.Cells(y + 6, 3) = "İsim Listesini Hazırlayan"
sh.Cells(y + 6, 8) = "Gerçekleştirme Memuru"
sh.Cells(y + 6, 18) = "Harcama Yetkilisi"
With sh.Range(sh.Cells(y + 6, 2), sh.Cells(y + 10, 20))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
With sh.Range(sh.Cells(2, 2), sh.Cells(3, 2)).Font
.Size = 14
.Bold = True
.Shadow = True
End With
With sh.Range("B4:T" & sh.Cells(65536, 2).End(xlUp).Row)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
.Font.Size = 9
End With
sh.Columns(1).ColumnWidth = 1.5
With sh.PageSetup
.PrintArea = "B2:T" & sh.Cells(65536, 2).End(xlUp).Row + 6
.PrintTitleRows = "$4:$4"
.PrintTitleColumns = ""
.LeftMargin = Application.InchesToPoints(0.354330708661417)
.RightMargin = Application.InchesToPoints(0.354330708661417)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 10
.PrintErrors = xlPrintErrorsDisplayed
End With

ElseIf Sheets("AnaSayfa").ListBox1.ListIndex = 1 Then

For i = 2 To shV.Cells(65536, 1).End(xlUp).Row
Set bul = shC.Columns(2).Find(shV.Cells(i, 1), , , xlWhole)
If Not bul Is Nothing Then
adres = bul.Address
Do
If shC.Cells(bul.Row, 15) = False And Tarih >= shC.Cells(bul.Row, 13) And Tarih <= shC.Cells(bul.Row, 14) Or shC.Cells(bul.Row, 6) = True Then
y = y + 1
ReDim Preserve arrVeri(1 To y)
For j = 1 To UBound(arrVeri)
If shV.Cells(i, 1) = arrVeri(j) Then: y = y - 1: GoTo f1
Next j
arrVeri(y) = shV.Cells(i, 1)
f1:
End If
Set bul = shC.Columns(2).FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
Next i

ReDim arrVeriAna(1 To UBound(arrVeri), 1 To 7)
For i = 1 To UBound(arrVeri)
Set bul = shC.Columns(2).Find(arrVeri(i), , , xlWhole)
If Not bul Is Nothing Then
adres = bul.Address
Do
'toplam1:İlkokul ve Lise harçlarının hesaplanması
toplam1 = toplam1 + (shC.Cells(bul.Row, 7) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 6) + _
shC.Cells(bul.Row, 8) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 7)) * (-1)

'Toplam2:Okul Yardımı
If Ay = 1 Or Ay = 8 Then
toplam2 = toplam2 + shC.Cells(bul.Row, 9) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * _
(shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5) * (-1)
Else
toplam2 = toplam2 + 0
End If
'toplam3:Giyim Yardımı
If Ay = 4 Or Ay = 9 Then
toplam3 = toplam3 + shC.Cells(bul.Row, 10) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * _
(shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5) * (-1)
Else
toplam3 = toplam3 + 0
End If
'toplam4:Yol Gideri
toplam4 = 0 'Yol gideri belli değil, elle girilecek
'Toplam5:Sosyal Yardım
toplam5 = toplam5 + shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 3) * _
(shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 4) / 100) * _
shK.Cells(shK.Cells(65536, 1).End(xlUp).Row, 5)
'toplam:Toplam yardım miktarı
toplam = toplam1 + toplam2 + toplam3 + toplam4 + toplam5
Set bul = shC.Columns(2).FindNext(bul)
Loop While Not bul Is Nothing And bul.Address <> adres
End If
If arrVeri(i) <> Empty Then
arrVeriAna(i, 1) = i
arrVeriAna(i, 2) = Application.WorksheetFunction.VLookup(arrVeri(i), shV.Range("A2:E" & shV.Cells(65536, 1).End(xlUp).Row), 2, False)
arrVeriAna(i, 3) = Application.WorksheetFunction.VLookup(arrVeri(i), shV.Range("A2:E" & shV.Cells(65536, 1).End(xlUp).Row), 3, False)
arrVeriAna(i, 4) = Ay1
arrVeriAna(i, 5) = toplam
arrVeriAna(i, 6) = Application.WorksheetFunction.VLookup(Application.WorksheetFunction.VLookup(arrVeri(i), shV.Range("A2:E" & shV.Cells(65536, 1).End(xlUp).Row), 4, False), shS.Range("A2:D" & shS.Cells(65536, 1).End(xlUp).Row), 3, False)
arrVeriAna(i, 7) = Application.WorksheetFunction.VLookup(arrVeri(i), shV.Range("A2:E" & shV.Cells(65536, 1).End(xlUp).Row), 5, False)
End If
toplam1 = 0: toplam2 = 0: toplam3 = 0: toplam4 = 0: toplam5 = 0: toplam = 0
Next i

Set wb = Workbooks.Add
Set sh = wb.Sheets(1)
ActiveWindow.DisplayGridlines = False
basliklar = Array("S.No", "Adı", "Soyadı", "Ay", "Tutarı", "Şube Kodu", "Hesap No")
sh.Cells(4, 2).Resize(, 7) = basliklar
sh.Cells(5, 2).Resize(UBound(arrVeri), 7) = arrVeriAna
sh.Columns(1).ColumnWidth = 1.5
sh.Cells(y + 5, 6).Formula = "=SUM(F5:F" & y + 4 & ")"
sh.Columns("B:H").EntireColumn.AutoFit
sh.Cells(2, 2) = "T.C. ZİRAAT BANKASI 31051213-5001 NOLU HESABA AİT"
sh.Cells(3, 2) = Ay1 & "-" & Yil & " AYNİ VE NAKDİ YARDIM LİSTESİDİR"
sh.Rows(y + 5).Font.Bold = True
sh.Cells(y + 5, 4) = "Genel Toplam"
sh.Cells(y + 6, 1) = "Ziraat Bankası Müdürlüğüne İl Müdürlüğümüz nakdi yardım hesabı olan 31051213-5001"
sh.Cells(y + 7, 1) = "Nolu hesaptan yukarıdaki ad ve soyadları ile hesap numaraları belirtilen şahısların hesabına"
sh.Cells(y + 8, 1) = "Belirtilen miktarların aktarılamsı hususunu arz ederiz."
sh.Cells(y + 11, 1) = "Listeyi Hazırlayan"
sh.Cells(y + 11, 5) = "Gerçekleştirme Memuru"
sh.Cells(y + 11, 8) = "Harcama Yetkilisi"
With sh.Range(sh.Cells(2, 2), sh.Cells(3, 2)).Font
.Size = 14
.Bold = True
End With
With sh.Range("B4:H" & sh.Cells(65536, 2).End(xlUp).Row)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End With
End If
Set shC = Nothing
Set shV = Nothing
Set shK = Nothing
Set shA = Nothing
Set shS = Nothing
Set sh = Nothing
Set wb = Nothing
End Sub
Bu kodlar kullandığım asıl kitapta formlara bağlı olarak çalışıyor sadece o yetkili isimlerini otomatik çağırmasını istiyorum.
 
E

Ercan_ÇELİKOĞLU

Katılım
5 Nisan 2007
Mesajlar
409
Excel Vers. ve Dili
excel 2010 tr
Lütfen çözüm yolu gösterin

Saygılarla
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst