Aynı Sayfada olan tüm firma ekstrelerinin ayrı sayfalara aktarma

Katılım
24 Temmuz 2009
Mesajlar
39
Excel Vers. ve Dili
EXCELL 2010 TÜRKÇE
Merhaba değerli arkadaşlar elimde bir tane dosya var ben bu dosyada aşağıdaki iki işlemden birini yapmak istiyorum, ancak konu makro bilgisi gerektirdiği için ben yapamadım yapabilecek arkadaşlar varsa yardımcı olurlarsa sevinirim.
Ekte gönderdiğim gibi bir cari hesap ekstre listem var, cari hesap ekstresini incelediğinizde (toplu ekstre alınmıştır) tüm firmaları tek bir excel dosyasında gösteriyor, oysa ben ayrı ayrı excel dosyalarında olmasını istiyorum. Bunu muhasebe programı üzerinden yapamadık, ne yazık ki

Yapmak istediğim olay şu muhasebe programımızdan cari hesap ekstresi alıyoruz tüm firmalarınkini toplu olarak bir excel sayfasına aktarıyor. Ben bu excel dosyasındaki her cari adı ve işlemlerini ayrı bir excel dosyasına cari adı ile otomatik kaydedebilirsem işim epey kolaylaşmış olacak
Örnek bir cari hesap ekstre görüntüsü ekteki gibidir

Yukarıdaki görselde gördüğünüz gibi Cari Adı Firma 1 de bir tanım başlıkları tarih evrak no evrak açıklama dvz cinsi borç alacak gibi satırlar var altında ise bu işleme ait veriler cari firma 1 de 4 işlem yapılmış cari firma 2 de 3 işlem yapılmış cari firma 3 te ise hem fazla işlem var hem de diğer iki firmadan ayrı olarak iki tane tanım satırı var şöyle ki cari kodunun altında firma 1 de olduğu gibi tarih evrak no evrak türü açıklama satırı var ancak işlemlerin sonunda stok kodu, stok adı, miktar gibi ikinci bir tanımlama satırı var
Burada makrolar yardımı ile tek sayfada kayıtlı olan bu cari hesapların firma1.xlsx, firma2.xlsx firma3.xlsx şeklinde kendi firmalarına ait şekilde ayırma imkanım olur mu?
Yada ikinci yol sütun adları belli olduğu için şunu yapabilir miyim?
Ekte bulunan excel dosyasında ikinci bir sheet var ben bu ikinci sheet e buradaki firma isimlerini satır satır oradaki başlıklara alabilir miyim
Yani cari firma1 e ait olan tarih evrak no evrak türü vs vs 2. Sheette bulunan sütunlara tek satır olarak işlensin mümkün olur mu
A sütununda cari hesap adı olacak B sütununda ise cari hesapların listesi olacak bunu yapabilirsem daha iyi olacaktır.

Ekstre örneği : https://drive.google.com/open?id=0B3dkEKhbK2yIYXd4WXgxRDJyMjA
 
Son düzenleme:
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Ek dosyayı deneyiniz,
Kodların çalışması her firma için "B" sütununda "Cari Kodu :" ibaresi ve "F:H" sütunları arasında
"Toplam Tutarlar :" ibaresinin örnekteki gibi bulunmasına bağlıdır.
http://s3.dosya.tc/server10/lvfjed/deneme.zip.html

Kod:
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
For Each a In Range("B1:B" & UsedRange.Cells.Rows.Count)
If a.Value = "Cari Kodu  :" Then
Set c2 = Range("F" & a.Row & ":H" & Rows.Count).Find("Toplam Tutarlar :", , xlValues, xlWhole, , , False)
 If Not c2 Is Nothing Then
  Set ktp = Workbooks.Add(1)
Range("A" & a.Row & ":T" & c2.Row).Copy
ktp.Sheets(1).Cells(1).PasteSpecial
ktp.Sheets(1).Cells.Font.ColorIndex = 1
s = s + 1
dosyam = "Firma " & s
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dosyam & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
End If
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Katılım
24 Temmuz 2009
Mesajlar
39
Excel Vers. ve Dili
EXCELL 2010 TÜRKÇE
İlginiz için teşekkür ederim PLİNT Deneyip bilgi vereceğim, çok teşekkür ederim
Merhaba
Ek dosyayı deneyiniz,
Kodların çalışması her firma için "B" sütununda "Cari Kodu :" ibaresi ve "F:H" sütunları arasında
"Toplam Tutarlar :" ibaresinin örnekteki gibi bulunmasına bağlıdır.
http://s3.dosya.tc/server10/lvfjed/deneme.zip.html

Kod:
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
For Each a In Range("B1:B" & UsedRange.Cells.Rows.Count)
If a.Value = "Cari Kodu  :" Then
Set c2 = Range("F" & a.Row & ":H" & Rows.Count).Find("Toplam Tutarlar :", , xlValues, xlWhole, , , False)
 If Not c2 Is Nothing Then
  Set ktp = Workbooks.Add(1)
Range("A" & a.Row & ":T" & c2.Row).Copy
ktp.Sheets(1).Cells(1).PasteSpecial
ktp.Sheets(1).Cells.Font.ColorIndex = 1
s = s + 1
dosyam = "Firma " & s
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dosyam & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
End If
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Katılım
24 Temmuz 2009
Mesajlar
39
Excel Vers. ve Dili
EXCELL 2010 TÜRKÇE
merhabalar, kodu çalıştırdım ancak kaydet dediğinde firma adını almıyor size gönderdiğim örnek dosyada firma1 firma2 diye örnek bir şekilde göndermiştim dosyaları ayrı ayrı kaydederken firma1.xls yerine asha ltd şti.xls gibi kaydetme imkanı var mı acaba
Merhaba
Ek dosyayı deneyiniz,
Kodların çalışması her firma için "B" sütununda "Cari Kodu :" ibaresi ve "F:H" sütunları arasında
"Toplam Tutarlar :" ibaresinin örnekteki gibi bulunmasına bağlıdır.
http://s3.dosya.tc/server10/lvfjed/deneme.zip.html

Kod:
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
For Each a In Range("B1:B" & UsedRange.Cells.Rows.Count)
If a.Value = "Cari Kodu  :" Then
Set c2 = Range("F" & a.Row & ":H" & Rows.Count).Find("Toplam Tutarlar :", , xlValues, xlWhole, , , False)
 If Not c2 Is Nothing Then
  Set ktp = Workbooks.Add(1)
Range("A" & a.Row & ":T" & c2.Row).Copy
ktp.Sheets(1).Cells(1).PasteSpecial
ktp.Sheets(1).Cells.Font.ColorIndex = 1
s = s + 1
dosyam = "Firma " & s
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dosyam & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
End If
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
merhabalar, kodu çalıştırdım ancak kaydet dediğinde firma adını almıyor size gönderdiğim örnek dosyada firma1 firma2 diye örnek bir şekilde göndermiştim dosyaları ayrı ayrı kaydederken firma1.xls yerine asha ltd şti.xls gibi kaydetme imkanı var mı acaba
Merhaba
Ek dosyayı deneyiniz
http://s3.dosya.tc/server10/lzymlm/deneme2.zip.html

Kodlarda [E:I] sütunlarında "Cari Adı" ibaresini arar, (firma adının örnekteki gibi "Cari adı" ibaresinin bulunduğu hücrenin yanında olacağı varsayılmıştır) bulduğunda [F:H] sütunlarında "Toplam Tutarlar" ibaresini arar bu bulduklarına göre işlem yapar.
Yani bu ibarelerin dosyada adı geçen sütunlara denk gelmesi önemlidir.
Kod:
 [SIZE="2"]Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Set s1 = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
sonsat = s1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
With s1.[E:I]
Set c = .Find("Cari Adı", , xlValues, xlPart, , False)
    If Not c Is Nothing Then
 f = c.Address
        Do
For Each a In Range("F" & c.Row & ":H" & sonsat)
If a.Value Like "Toplam Tutarlar" & "*" Then
     Set ktp = Workbooks.Add(1)
Range("A" & c.Row & ":T" & a.Row).Copy
ktp.Sheets(1).Cells(1).PasteSpecial
ktp.Sheets(1).Cells(1).Select
ktp.Sheets(1).Cells.Font.ColorIndex = 1
If s1.Cells(c.Row, c.Column + 1) = "" Then dosyam = c.Row
dosyam = s1.Cells(c.Row, c.Column + 1)
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dosyam & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
Exit For
End If
Next
 Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub [/SIZE]
 
Katılım
24 Temmuz 2009
Mesajlar
39
Excel Vers. ve Dili
EXCELL 2010 TÜRKÇE
yardımlarınız için çok teşekkür ederim, şöyle bir rica da bulunabilir miyim cari adı sonrasında bazen hemen yanındaki sütun bazense cari adı bir sütun boş diğer sütunda cari adı olabiliyor bu nedenle cari adını hemen yanındaki 3 sütunda arasa bu sorunu da düzeltmiş olacağım bunun için kodlara ne eklemem gerekli

size gönderdiğim örnekte cari adı f sütununda g sütununda ise firmanın adı yazıyor ama bazı firmalarınki h sütununda olabiliyor örnek ekran görüntüsü aşağıdaki gibidir resimde gördüğünüz üzere üstte bazı firmalar cari adı yanında boşluk var yani g sütununa denk gelen alan, cari adı doğru yerde ama firmanın tam adı h sütununda yazıyor, altındaki firma ise cari adı f sütununda yine doğru ancak firmanın tam adı g sütununda yer alıyor.


Merhaba
Ek dosyayı deneyiniz
http://s3.dosya.tc/server10/lzymlm/deneme2.zip.html

Kodlarda [E:I] sütunlarında "Cari Adı" ibaresini arar, (firma adının örnekteki gibi "Cari adı" ibaresinin bulunduğu hücrenin yanında olacağı varsayılmıştır) bulduğunda [F:H] sütunlarında "Toplam Tutarlar" ibaresini arar bu bulduklarına göre işlem yapar.
Yani bu ibarelerin dosyada adı geçen sütunlara denk gelmesi önemlidir.
Kod:
 [SIZE="2"]Private Sub CommandButton1_Click()
Dim s1 As Worksheet
Set s1 = ThisWorkbook.ActiveSheet
Application.ScreenUpdating = False
sonsat = s1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
With s1.[E:I]
Set c = .Find("Cari Adı", , xlValues, xlPart, , False)
    If Not c Is Nothing Then
 f = c.Address
        Do
For Each a In Range("F" & c.Row & ":H" & sonsat)
If a.Value Like "Toplam Tutarlar" & "*" Then
     Set ktp = Workbooks.Add(1)
Range("A" & c.Row & ":T" & a.Row).Copy
ktp.Sheets(1).Cells(1).PasteSpecial
ktp.Sheets(1).Cells(1).Select
ktp.Sheets(1).Cells.Font.ColorIndex = 1
If s1.Cells(c.Row, c.Column + 1) = "" Then dosyam = c.Row
dosyam = s1.Cells(c.Row, c.Column + 1)
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & dosyam & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
Exit For
End If
Next
 Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub [/SIZE]
 
Üst