Banka Listesi Olusturma

Hacı Bayram ÖZKAN · 10 Eylül 2016

Merhaba arkadaşlar; Ekli dosyamdaki Liste sayfamda bulunan tabloya göre D'de bulunan Belgelerim/Banka Klasörünün içinde yine ekli dosyamın Banka Listesi sayfasında bulunan örnekdeki gibi bir dosya oluşturmasını istiyorum. Yani elimde bulunan listeye göre banka formatına uygun bir banka dosyası oluşturulacak buda her ay bankaya gönderilecek.
Yardımcı olacak arkadaşlara şimdiden teşekkürler.

TEGCreative · 10 Eylül 2016

Merhaba ; liste sayfasına bir buton koyup ve bir modül açıp içine kodları kopyalayıp
Banka Listesi sayfasını da Formüllerle bilgileri oraya alıp bu makroyu dener misiniz ?

Kod:

Sub ListeOlustur()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim dosyayolu, isim As String
dosyayolu = "D:\Belgelerim\Banka\"
isim = Sheets("BANKA LİSTESİ").Name & Sheets("LİSTE").Range("K23").Value
Sheets("BANKA LİSTESİ").Copy
ActiveSheet.SaveAs dosyayolu & isim & ".xlsm"
Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        ActiveWorkbook.Save
        ActiveWorkbook.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox dosyayolu & isim & " isimli belgeniz kaydedildi.Teşekkürler.", vbOKOnly, "TEGCreative GTWO"
End Sub

Hacı Bayram ÖZKAN · 10 Eylül 2016

Teşekkürler sayın abim şuan deneme imkanım yok sonra deneyeceğim
Teşekkürler

Hacı Bayram ÖZKAN · 10 Eylül 2016

Merhaba arkadaşlar; sorum yanlış anlaşılmış galiba
İsteğim şöyle olacak LİSTE sayfamdaki verilere göre bunun C ve D sütunlarındaki AD VE SOYADLAR birleştirilecek, yeni dosyada A Sütununa B VE C sütunları boş olacak, D Sütununa IBANLARI, E Sütuna toplam miktarı olacak şekilde yeni bir dosya oluşturulacak, oluşturulacak bu dosya D\Belgelerim\Banka klasörünün içinde olacak, oluşturulacak dosya örneği Banka Listesi sayfasında mevcut teşekkürler.

halit3 · 11 Eylül 2016

kırmızı bölüme dosyanın kayıt yapıldığı klasör yolunu yazınız.

Kod:

Sub yeni_dosya_oluştur()
'On Error Resume Next

kaynak = [COLOR="Red"]ThisWorkbook.Path[/COLOR]

Application.DisplayAlerts = False

ay = Format(Now, "mmmm")
yıl = Format(Now, "yyyy")

dosya_adı = InputBox("dosyanın adını yazınız", "UYARI", ay & " KESİNTİSİ " & yıl)

If dosya_adı = "" Then
MsgBox "Sayfa ismini yazmadınız"
Exit Sub
End If

kesinti = InputBox("kesinti nedeni", "UYARI", ay & " AYI KESİNTİSİ")

If kesinti = "" Then
MsgBox "kesinti ayını yazınızSayfa ismini yazmadınız"
Exit Sub
End If
Workbooks.Add

dosya = ActiveWorkbook.Name
sayfa_Adı = ActiveSheet.Name


For ii = ActiveWorkbook.Sheets.Count To 2 Step -1
ActiveWorkbook.Sheets(ii).Delete
Next


sat = 1
For i = 2 To ThisWorkbook.Worksheets("LİSTE").Cells(Rows.Count, "C").End(3).Row

ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 1).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 3).Value [COLOR="Red"]& " " & [/COLOR]ThisWorkbook.Sheets("LİSTE").Cells(i, 4).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 4).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 11).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 5).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 29).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 6).Value = kesinti

sat = sat + 1
Next i

Columns("A:G").Columns("A:G").EntireColumn.AutoFit
Range("a1").Select
ActiveWorkbook.SaveAs kaynak & "\" & dosya_adı & ".xls"
ActiveWindow.Close
ActiveWindow.WindowState = xlMaximized

Application.DisplayAlerts = True
MsgBox "işlem tamam"


End Sub

Hacı Bayram ÖZKAN · 11 Eylül 2016

Halit bey eline sağlık teşekkürler dua ile kal
Herkese iyi bayramlar.

Hacı Bayram ÖZKAN · 13 Eylül 2016

Bayramınız kutlu olsun arkadaşlar; halit beyin hazırladığı kodu dosyamda çalıştırırken
For i = 2 To ThisWorkbook.Worksheets("LİSTE").Cells(Rows.Count, "C").End(3).Row
bu satırda hata veriyor ayrıca yeni oluşturulan dosyada ad ve soyad arasına boşluk koymuyor, bakar mısınız? Teşekkürler
Dosyanın bulunduğu yer. http://s9.dosya.tc/server/7v7n8d/BANKA_LISTESI.xls.html

Hacı Bayram ÖZKAN · 18 Eylül 2016

Merhaba arkadaşlar
7 nolu mesajdaki dosyam hata veriyor bakabilir misiniz?

halit3 · 18 Eylül 2016

5 nolu mesajdaki kodu yeniden deneyiniz.

Kod:

For i = 2 To ThisWorkbook.Worksheets("LİSTE").Cells(Rows.Count, "C").End(3).Row

liste sayfasında c sutununda en az bir değer olmalı

Hacı Bayram ÖZKAN · 18 Eylül 2016

Halit bey denedim bir türlü istediğim gibi çalışmadı yine aynı yerde duruyor, lİSTE Sayfamda değil bir değer şuan 20 değer var ama yine o satırda hata veriyor. Bir türlü anlamadım.

halit3 · 18 Eylül 2016

tarzanhaci' Alıntı:
Halit bey denedim bir türlü istediğim gibi çalışmadı yine aynı yerde duruyor, lİSTE Sayfamda değil bir değer şuan 20 değer var ama yine o satırda hata veriyor. Bir türlü anlamadım.

hata veren dosyayı buraya ekle

kodlar 1 nolu mesajınızdaki dosyada çalışıyor.

halit3 · 18 Eylül 2016

Sizin 7 nolu mesajınızdaki kodda kayıt yaparken / (slaç) işareti fazla olduğundan belkide işlem yapmıyordur.

Kod:

Sub yeni_dosya_oluştur()
'On Error Resume Next

kaynak = "D:\Belgelerim\Banka\"

Application.DisplayAlerts = False

ay = Format(Now, "mmmm")
yıl = Format(Now, "yyyy")

dosya_adı = InputBox("Dosyanın adını yazınız", "UYARI", ay & " KESİNTİSİ " & yıl)

If dosya_adı = "" Then
MsgBox "Sayfa ismini yazmadınız"
Exit Sub
End If

kesinti = InputBox("kesinti nedeni", "UYARI", ay & " AYI KESİNTİSİ")

If kesinti = "" Then
MsgBox "Kesinti ayını yazınız Sayfa ismini yazmadınız"
Exit Sub
End If
Workbooks.Add

dosya = ActiveWorkbook.Name
sayfa_Adı = ActiveSheet.Name


For ii = ActiveWorkbook.Sheets.Count To 2 Step -1
ActiveWorkbook.Sheets(ii).Delete
Next


sat = 1
For i = 2 To ThisWorkbook.Worksheets("LİSTE").Cells(Rows.Count, "C").End(3).Row

ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 1).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 3).Value & " " & ThisWorkbook.Sheets("LİSTE").Cells(i, 4).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 4).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 11).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 5).Value = ThisWorkbook.Sheets("LİSTE").Cells(i, 29).Value
ActiveWorkbook.Sheets(sayfa_Adı).Cells(sat, 6).Value = kesinti

sat = sat + 1
Next i

Columns("A:G").Columns("A:G").EntireColumn.AutoFit
Range("a1").Select
ActiveWorkbook.SaveAs [COLOR="Red"]kaynak & dosya_adı[/COLOR] & ".xls"
ActiveWindow.Close
ActiveWindow.WindowState = xlMaximized

Application.DisplayAlerts = True
MsgBox "İşlem Tamam"


End Sub

Hacı Bayram ÖZKAN · 18 Eylül 2016

http://s9.dosya.tc/server/07moj2/BANKA.xls.html
Bu dosyamda bir türlü çalışmıyor

Hacı Bayram ÖZKAN · 18 Eylül 2016

Çok garip bazen çalışıyor ama daha sonra hiç çalışmıyor. Anlamadım. Zahmet verdim kusura bakmayın iyi geceler.

halit3 · 18 Eylül 2016

tarzanhaci' Alıntı:
http://s9.dosya.tc/server/07moj2/BANKA.xls.html
Bu dosyamda bir türlü çalışmıyor

Kod:

kaynak = "D:\Belgelerim\Banka[COLOR="red"]\[/COLOR]"

Kod:

ActiveWorkbook.SaveAs kaynak & [COLOR="Red"]"\" &[/COLOR] dosya_adı & ".xls"

yukarıdaki bölümlerden kırmızı olan yerin bir tanesini siliniz.

ikisini silmeyiniz sadece birini (kırmızı olan bölüm) silin

Hacı Bayram ÖZKAN · 18 Eylül 2016

sayın hocam dediğiniz her şeyi denedim yinede olmadı teşekkürler. İyi geceler. Zahmet verdim. İlk defa böyle oldu genelde sizin kodlar %100 çalışıyordu. Dua ile kalın.

Hacı Bayram ÖZKAN · 18 Eylül 2016

Bunu da siz hazırlamış tınız Halk bankası için

Kod:

Private Sub CommandButton9_Click() 'Kesinti için
Application.ScreenUpdating = False
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Application.DisplayAlerts = False
Kaynak = "D:\Belgelerim\Banka\"
yeni_dosya_adı = Format(Worksheets(ActiveSheet.Name).Cells(1, 17).Value, "MMMM YYYY")
Dim ExcelSheet As Object
On Error Resume Next
CreateObject("Excel.Sheet").SaveAs Kaynak & yeni_dosya_adı & ".xls"
Application.DisplayAlerts = True

Dosya = Kaynak & yeni_dosya_adı & ".xls"
On Error Resume Next
Dim wb As Workbook
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Dosya)
yenidosya_adı = ActiveWorkbook.Name
Windows(yenidosya_adı).Activate
SAT = 1

For i = 3 To ThisWorkbook.Sheets(Sayfa_Adı).[b65536].End(3).Row
ALAN2 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 13).Value

ALAN2 = LeftPadChar(ALAN2, "0", 8) & ""
ALAN3 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 16).Value
n2 = InStr(ALAN3, ",")
ALAN4 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 4).Value
ALAN5 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 3).Value

If n2 > 0 Then
ALAN3 = Mid(ALAN3, 1, n2 - 1) & "," & Mid(ALAN3, n2 + 1, 2)
End If
ALAN3 = Format(ALAN3, "#,##0.00")
ALAN4 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(i, 4).Value
Cells(SAT, 1).Value = "20140215"
Cells(SAT, 2).Value = "15514287"
Cells(SAT, 3).Value = "1254"
Cells(SAT, 4).Value = "04000012"
Cells(SAT, 4).NumberFormat = "########00000000"

Cells(SAT, 5).Value = "1254"
Cells(SAT, 6).Value = ALAN2
Cells(SAT, 6).NumberFormat = "########00000000"

Cells(SAT, 7).Value = ALAN3
Cells(SAT, 7).Value = ALAN3 * 1
Cells(SAT, 7).NumberFormat = "#,##0.00"
Cells(SAT, 8).Value = ALAN4
Cells(SAT, 9).Value = ALAN5


SAT = SAT + 1
Next
Worksheets("Sayfa1").Columns("A:I").EntireColumn.AutoFit
wb.Save
Windows(dosya_adı).Activate
yer = Dosya
Dosya = Dir
wb.Close False
ActiveWindow.WindowState = xlMaximized
Application.ScreenUpdating = True
MsgBox " Kesinti için dosya oluşturdum, TOPLAM " + Str(SAT - 1) + " Kişinin Kesintisi bankaya gönderilmeye hazır.", vbOKOnly, "Sayın Ali TEKİN"

End Sub

Ama nedense bu çalışmadı yada bunu ona göre ayarlarmısınız.

halit3 · 18 Eylül 2016

sizin soru birden bire farklılaştı

12 nolu mesajdaki kodu buraya eklediğiniz dosyada denedinizmi.

Hacı Bayram ÖZKAN · 18 Eylül 2016

Yeni buldum deneyeceğim ama yarın inşallah sağlıcakla kalın

halit3 · 18 Eylül 2016

12 nolu mesaj daki kod olacaktı

Banka Listesi Olusturma

Hacı Bayram ÖZKAN

TEGCreative

Hacı Bayram ÖZKAN

Hacı Bayram ÖZKAN

halit3

Uzman

Hacı Bayram ÖZKAN

Hacı Bayram ÖZKAN

Hacı Bayram ÖZKAN

halit3

Uzman

Hacı Bayram ÖZKAN

halit3

Uzman

halit3

Uzman

Hacı Bayram ÖZKAN

Hacı Bayram ÖZKAN

halit3

Uzman

Hacı Bayram ÖZKAN

Hacı Bayram ÖZKAN

halit3

Uzman

Hacı Bayram ÖZKAN

halit3

Uzman