başka excel sayfasına veri kaydetme

[asiiiruzgar]

Arkadaşlar benim üzerinde çalıştığım 10 adet defter var bunlarında adı
902-903-904-905-910-931-930-920-901-900
bu defterlere işlemeyi tek bir yerden yapıp ilgili yerlere kendi kaydedermi acaba
açılamalı bir şekilde ekte gönderdim incelerseniz sevinirim.
olmayacak bir şeyse beni uyarırsanız sevinirim
boşuna ümitlenmeyim bari.

 

[Recep İpek]

boşuna ümitlenmeyim bari.

Bence ümitlenin derim.
Çünkü excelde yapılamayacak birşey yoktur.

Aşağıdaki kodları kullanabilirsiniz.

Tüm dosyalarınızın aynı klasörde ve maksimum 3 adet tablonuzun olduğu düşünülmüştür.

Sub Kaydet01()
Dim durum As Boolean
Set s1 = Sheets("giriş")
son = 0
sira = 0
Application.ScreenUpdating = False
For i = 2 To [a65536].End(3).Row
baskanlik = s1.Cells(i, "a").Value
dosya = ThisWorkbook.Path & "/" & baskanlik & ".xls"
sayfakodu = s1.Cells(i, "b").Value
altkodu = s1.Cells(i, "e").Value
adisoyadi = s1.Cells(i, "f").Value
tahakkuk = s1.Cells(i, "h").Value
tarihi = s1.Cells(i, "I").Value
tutari = s1.Cells(i, "j").Value
durum = False
'************************************
Set xlBook = Workbooks.Open(dosya)
Set Sh = xlBook.Sheets(sayfakodu)
    No1 = WorksheetFunction.Count(Sh.Range("a22:a48"))
    No2 = WorksheetFunction.Count(Sh.Range("a55:a94"))
    No3 = WorksheetFunction.Count(Sh.Range("a101:a140"))
    toplam = No1 + No2 + No3
    If toplam >= 0 And toplam < 27 Then
    son = No1 + 1 + 21
    sira = No1 + 1
    ElseIf toplam >= 27 And toplam < 67 Then
    son = No2 + 1 + 21 + 6 + 27
    sira = No2 + 1
    ElseIf toplam >= 67 And toplam < 107 Then
    son = No3 + 1 + 21 + 6 + 27 + 6 + 40
    sira = No3 + 1
    Else
    MsgBox baskanlik & " Dosyasında Yeterli TABLO Tanımlı Değil."
    Exit Sub
    End If
    Sh.Cells(son, "a") = sira
    Sh.Cells(son, "b") = tarihi
    Sh.Cells(son, "e") = tahakkuk
    Sh.Cells(son, "g") = adisoyadi
    For Each bul In Sh.Range("V20:BY20")
    If bul = altkodu Then
    Col = bul.Column
    durum = True
    End If
    Next
    If durum = False Then
    MsgBox baskanlik & " dosyasında " & sayfakodu & " Sayfasında " & altkodu & " Alt Kodu Tanımlı Değil."
    Exit Sub
    End If
    Sh.Cells(son, Col) = tutari
    xlBook.Save
    xlBook.Close
Set xlBook = Nothing
Set xlApp = Nothing
'************************************
Next i
MsgBox "Tüm Bilgiler İlgili Tablolara Aktarıldı."
Application.ScreenUpdating = False
Set s1 = Nothing
'www.excel.web.tr/ripek
End Sub

 

[asiiiruzgar]

çok GÜzel

Sayın Ripek Çok Teşekkür Ederim. Yanlız
Tablo 3 Tane İle Sınırlı Kalmış ben Bunu 15 Yapmam İçin ne Yapmam Lazım
ve Deftere Giriş Kısmı Satır Sayısını Çoğaltırsam Hepsini Alırmı Keydet Butonuna Tıkladığım An..
Yani Alt Altta 100 Evrak Yazdığımda Hepsini İlgili Sayfalara Aktarır Değilmi.

 

[Recep İpek]

Deftere Giriş Kısmı Satır Sayısını Çoğaltırsam Hepsini Alırmı Keydet Butonuna Tıkladığım An..
Yani Alt Altta 100 Evrak Yazdığımda Hepsini İlgili Sayfalara Aktarır Değilmi.

Arada boşluk olmamak kaydıyla istediğiniz satıra kadarki kayıtları alır.

 

[asiiiruzgar]

Arada boşluk olmamak kaydıyla istediğiniz satıra kadarki kayıtları alır.

Ben Ekte Gönderiyorum 10 Tablodanda Fazla Olabilir Siz Bi Kontrol Edersiniz Göndermiş Olduğum Kadar Tablo Olsun Yeter Bana Oda Herhalde 18 veya 20 Tablo
Birde Yazmış Olduğum Bilgileri Diğer Sayfaya Atıyorda Sıra No Kısmı 27 den sonra tekrar 1 diye Başlıyor Onu 27 den 28 Gelecek Şekilde yani Sıra No Hiç Baştan Başlamıyacak Bir Başladımmı Ardarda Gitmesi Lazım.
Çok Teşekkürler.
Sayfa 03-9 Daki Tablo Sayısını baz alırsan iyi olur diğerleri hep o tablo sayısına ulaşacak

 

[Recep İpek]

Bu iş için en pratik yol, tablolardaki sıra sumaralarının dolu olmasıdır.

Ancak bu şekilde son kayıt satırını rahatlıkla bulabiliriz.

Bu arada kaydedilecek dosyanın bulunamaması durumdaki uyarıyıda halletmiş olduk...
Kodlarıda aşağıdaki şekilde düzeltiniz.

Sub Kaydet01()
Dim durum As Boolean
Set s1 = Sheets("giriş")
Application.ScreenUpdating = False
For i = 2 To [a65536].End(3).Row
baskanlik = s1.Cells(i, "a").Value
dosya = ThisWorkbook.Path & "/" & baskanlik & ".xls"
sayfakodu = s1.Cells(i, "b").Value
altkodu = s1.Cells(i, "e").Value
adisoyadi = s1.Cells(i, "f").Value
tahakkuk = s1.Cells(i, "h").Value
tarihi = s1.Cells(i, "I").Value
tutari = s1.Cells(i, "j").Value
durum = False
'************************************
kontrol = Dir(dosya)
If kontrol <> Empty Then
Set xlBook = Workbooks.Open(dosya)
Set Sh = xlBook.Sheets(sayfakodu)
    '********************************
    For j = 22 To 876  [color=red] '876 say&#305;s&#305;n&#305; maksimum tablo say&#305;s&#305;n&#305;n son sat&#305;r&#305;na g&#246;re [/color]d&#252;zeltiniz.
        If IsNumeric(Sh.Cells(j, "a").Value) = True And Sh.Cells(j, "b").Value = "" Then
            son = Sh.Cells(j, "a").Row
            Exit For
        End If
    Next j
    Sh.Cells(son, "b") = tarihi
    Sh.Cells(son, "e") = tahakkuk
    Sh.Cells(son, "g") = adisoyadi
    For Each bul In Sh.Range("V20:BY20")
    If bul = altkodu Then
    Col = bul.Column
    durum = True
    End If
    Next
    If durum = False Then
    MsgBox baskanlik & " dosyas&#305;nda " & sayfakodu & " Sayfas&#305;nda " & altkodu & " Alt Kodu Tan&#305;ml&#305; De&#287;il."
    Exit Sub
    End If
    Sh.Cells(son, Col) = tutari
    xlBook.Save
    xlBook.Close
Set xlBook = Nothing
Set xlApp = Nothing
Else
MsgBox baskanlik & " dosyas&#305; bulunamad&#305;"
Set s1 = Nothing
Exit Sub
End If
'************************************
Next i
MsgBox "T&#252;m Bilgiler &#304;lgili Tablolara Aktar&#305;ld&#305;."
Application.ScreenUpdating = False
Set s1 = Nothing
'www.excel.web.tr/ripek
End Sub

 

[asiiiruzgar]

oLMADI

Sayın Ripek Göndermiş Olduğunuz Kodları uyguladım Daha Önce Çalışan Program Şuan Çalışmıyor sebebini Bir Türlü Bulamadım.
Benim Sorunum İlk Siz Bana Göndermiş Olduğunuz Kod Çok Güzel Çalışıyor
Sorun Olarak Şunlar Var Ben Size Defter Giriş İle Bir Tane 904 Dosyası Gönderecem Kontrol Ederseniz Sevinitim.
Sorunlar Şunlar
1- Sıra No Kısmında Yazan numaralar 1 den başlayıp toplolar değiştikçe çoğalmasını istiyorum. her tablo başında yeniden 1 diye başlamasını istemiyorum.
2- Sıra No Şu Şekilde Ben Defterde Formüllemiştim yanındaki belli başlı hücreler dolunca otomatik numara veriyor yani üsteki no kaçsa bir sonrakini veriyor o şekilde kalsa olmazmı defterde (sıra no olan kısmında herhangibir rakam vermesini istemesek tabloda sıra no kısmına bakarsananız anlarsanız. zaten. kendisi otomatik verecek
3-tablo sayıları en çok bu defterde yani 904 dosyasında oluyor tablo sayısını 3 değilde bu 904 de bulunan tablo sayısı kadar verebilirmiyiz yani 15 ile 20 tablo sayısı

 

[Recep İpek]

Bu iş için en pratik yol, tablolardaki sıra numaralarının dolu olmasıdır.

Ancak bu şekilde son kayıt satırını rahatlıkla bulabiliriz.

Sn.asiiiruzgar

İlgili mesajımda belirttiğim gibi her tablodaki sıra numaralarının elle girilerek dolu şekilde olması gerekmektedir.

 

[asiiiruzgar]

hım anladım tamam
peki tablo sayısı 3 ile sınırlıydı 10 15 ile 20 ye çıkaramayızmı

 

[Recep İpek]

    '********************************
    For j = 22 To 876  [color=red] '876 sayısını maksimum tablo sayısının son satırına göre [/color]düzeltiniz.
        If IsNumeric(Sh.Cells(j, "a").Value) = True And Sh.Cells(j, "b").Value = "" Then

Bunun için hiçbir şey yapmanıza gerek yok.

Sadece yine mesajda belirtildiği gibi 876 sayısını son tablonun son satırına göre düzeltmeniz yeterlidir.

 

[asiiiruzgar]

Yapamadım

Sn. Ripek Ben beceremedim Size Ben Dosyayı Göndersem Nerde Hata Yapıyorum anlamadım eklediğim zamanda keydetmiyor.

 

[Recep İpek]

Ekli dosyalarda gerekli düzenleme ve açıklamalar yapılmıştır.

.....

 

[asiiiruzgar]

sn. ripek

Sizin Göndermiş Olduğunuz Dosyaları aldım ve yazmış olduğunuz açıklamayı uyguladım bütün tabloları 1 den en sona kadar numaralandırdım
fakat deftere giriş yerinde yazdığım bilgiler kaydet butonuna tıkladığım an gitmiyor uyarıda tüm biligler ilgili tablolara aktarıldı diyor ama bakıyorum aktarılmamış. sebebi ne.

 

[Recep İpek]

Dosyalarınızı tekrar ekleyebilirmisiniz?

 

[asiiiruzgar]

Sn Ripek

Ben Şu Şekilde Bir Düzelttme Yaptım Ama Tablo Üç De kalıyor gene
Bir Bakarsanız Sevinirim
Eğer Yasnlışşa Tamamiyle
Ben Size Sizin Göndermiş olduğunuz Makrolu Dosyayı Göndereyim.

 

[asiiiruzgar]

Sn. Ripek

Bu Şekilde Çok Güzel Çalışıyor Ben Düzeltmeyi yapınca
Sorun Olarak SAdece Sıra No Kısmı Kqldı Kendisi 27 den sonra 28-29-30 diye sırayla gidemezmi bir baksanız ona bir de ben tablo olarak 180 küsür kayır yaptım tablo 5 kadar geldi hepsi normal olarak çalışıyor
ama benim göremiyeceğim bir hata varsa beni uyarında sonra başıma büyük bir dert almayım ödenek konusunda

 

[asiiiruzgar]

dosya

ben xls olarak gönderiyorum siz kontrol edersiniz ben sıkıntılarımı bir önceki üzette bulannan mesajlara göre size iletmiştim
sıra numarasını otomatik istemiyorum yanlız sizin dediğiniz gibi sıranumarasını önceden kendim versem gene olmuyor sıra numarasını karşılığı boş bile olsa o sıra numarasından sonrakini kendi 1 den başlayarak yaıyor

 

[Recep İpek]

Kodları aşağıdaki şekilde değiştiriniz.

Sh.Cells(son, "a") = toplam + 1
Sh.Cells(son, "b") = tarihi
Sh.Cells(son, "e") = tahakkuk
Sh.Cells(son, "g") = adisoyadi

Peki siz neden bu kodları kullandığınızı yazmadınız? Bende son yazdığım kodlar üzerinden gidiyorum.
Sonuçta birkaç gündür boşuna çabalıyoruz.

 

[asiiiruzgar]

Sn. Ripek

Ben Bugun Öğle Paydosunda Yazdım Ama Becerebildiğime Sevindim Şimdi Sizin Göndermiş olduğunuz kodları ekleyecek bakalım olur inşallah

 

[asiiiruzgar]

sN. rİPEK

Çok teşekkür ederim tam istediğim gibi çalışıyor valla çok güzel
ellerinize ve aklınıza sağlık peki sizden son kez bir yardım daha talep edebilirmiyim buda tamamlanırsa hiç bir sorun kalmayacak allaha şükürler olsun
sorun şu bu defterlere bir de gelen ödenekler yazılıyor oda defterin üzerinde bulunan kısma oralarıda aynı bu şekilde ayrı bir veri girişi sayfasında ekleme yapabilirmiyiz.
örenek olarak ekte dosya gönderdim daha açıklamalı orda yazıyor
inanın beni çok sevindirdiniz. teşekkürler tekrardan