Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 12-02-2017, 21:51   #1
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan Kapalı dosyadan bazı sütunları alıp CSV olarak kayıt etmek

Merhaba arkadaşlar,

Kapalı bir dosyam var içinden bazı sütunları açık olan dosyama çekmek istiyorum. Sonra açık olan dosyamı CSV olarak 20'şer satır olarak ayrı ayrı bir klasörün içine kayıt etsin.

Örn: KAYIT-01
KAYIT-02
KAYIT-03 gibi

Aslında kapalı dosyadan bilgilerin hepsini alabiliyorum ama içinden bazı sütunları hatasız alamadım.

Esen kalın
Eklenmiş Dosyalar
Dosya Türü: xlsx Kapalı.xlsx (48.6 KB, 13 Görüntülenme)
Dosya Türü: xlsm Dosya Aktar.xlsm (30.7 KB, 13 Görüntülenme)
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 13-02-2017, 22:08   #2
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

Herkese merhaba,

Yardımcı olabilecek arkadaşlar var mı acaba, dosyam aslında sade ve kapalı dosyadan verilerin tamamını bende alabiliyorum. Ancak istenilen sütunları beceremedim.

Birde açık olan dosyaya çekilen verileri 20'şer satır olarak CSV formatında kayıt etmek. Ekli dosyada gerekli açıklama vardır.

Şimdiden herkese teşekkür eder saygılar sunarım.
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 14-02-2017, 22:23   #3
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

Merhaba,

Konu hakkında yardımcı olabilecek arkadaşlara şimdiden tekrar teşekkür ederim. Kapalı dosyadan istenilen bazı sütunları çekmek örneği de olsa yeterli olur sanırım. Ben kalanını tamamlamaya çalışırım.

Saygılar
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 17-02-2017, 11:36   #4
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 860
Excel Vers. ve Dili:
2010-2016
Varsayılan

Aşağıdaki kodları kullanabilirsiniz.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim Baglanti, sorgu, rs As Object, xx As Variant, yy As Long, ilk As Long

 
Function verigetir(aaa As Variant)
 
    Set Baglanti = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = ThisWorkbook.Path & "\kapalı.xlsx"
    Baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosyayolu & ";extended properties=""excel 12.0;hdr=no"""
    sorgu = "SELECT count(f1) FROM [FaturaListesi$A2:I1048576]"
    rs.Open sorgu, Baglanti, 1, 1
    
    
 If rs.RecordCount > 0 Then aaa = rs(0).Value


End Function
Sub Veri_Aktar()
Dim Kayit As Integer
Range("A5:L65000").ClearContents
xx = verigetir(aaa)
yy = aaa + 1 ' 1 in sebebi 2.satirdan baslandigi icin.
Sonsatir = yy
ilk = 2
Kayit = 0

    For i = ilk To yy Step 20
    Kayit = Kayit + 1
    Set Con = CreateObject("Adodb.Connection"):  Set rs = CreateObject("Adodb.RecordSet")
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\kapalı.xlsx" & ";extended properties=""excel 12.0;hdr=no;imex=1"""
    
       sorgu = "Select f1,f3,'',f4,'',f6,f8,'',f12 from [FaturaListesi$A" & i & ":L" & i + 20 & "]"" ' where f3 = '" & Range("N2").Value & "'"
 
        rs.Open sorgu, Con, 1, 1
        Range("a5").CopyFromRecordset rs
         rs.Close: Con.Close
         Set Con = Nothing: Set rs = Nothing: sorgu = Empty
         ActiveWorkbook.SaveAs Filename:= _
          ThisWorkbook.Path & "\KAYIT - " & Kayit & ".csv", FileFormat:=xlCSV _
        , CreateBackup:=False
    Next i
    
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 17-02-2017, 18:04   #5
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

Sayın Askm,

Öncelikle ilginize ve elinize sağlık diyorum.

Şu an deniyorum aktarmada sorun gözükmüyor görünüyor. Yalnız Makroyu 2 bölebilirmiyiz. Yani veriler bir makro tuşu ile gelsin ve ikinci makro tuşu ile 20'şer satır olarak CSV kayıt edeyim. (Hangi klasör içinde isem oraya kayıt edebilir) Otomatik kayıt etmesin demek istiyorum.

Tek bir kural önemli veriler açık olan dosyanın 2. satırından sonra yazılmalı ve kayıt edilecek CSV dosyaları da 2. satırdan itibaren kayıt etsin.

Bu CSV dosyasını ticari program içine çekiyorum.

Tekrar teşekkür eder ellerinize bilginize sağlık diyorum.

Esen kalın
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 17-02-2017, 18:13   #6
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

Sayın Askm,

Kayıt edilen CSV satırlarını A5 den itibaren tek hücreye yazıyor. Oysa geldiği gibi ilgili sütunlara ayrı ayrı 2. satırdan itibaren yazmalıydı.

Kayıt ederken 21. satırdan sonra A sütununa aşağıya doğru "....." yazıyor. 20. satırdan sonra hiç bir şey yazmamalı.

Tekrar teşekkür ederim.
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-02-2017, 22:10   #7
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

İyi akşamlar Askm,

Sizi yoruyorum kusura bakmayın lütfen. Makroyu ben denedim ama eksiksiz VERİ GETİR ve CSV KAYDET diye ikiye bölemedim.

Birde, Kayıt edilen CSV satırlarını A5 den itibaren tek hücreye yazıyor. Oysa geldiği gibi ilgili sütunlara ayrı ayrı 2. satırdan itibaren yazmalıydı. 20. satırdan sonrada son mesajımda yazdığım gibi "...... "çiziyor.

Tekrar çok teşekkür ederim.
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-02-2017, 07:40   #8
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 860
Excel Vers. ve Dili:
2010-2016
Varsayılan

Kodları ayırmak için aşağıdaki şekilde yaptım.
*O2 satırına kaçıncı kaydı almak istediğinizi yazmanız gerek. (İlk 20 değer için 1 son 20 değer için 26 gibi)
*R2 hücresine kaç değer olabileceği kod içerisinde otomatik geliyor.
*Kod halinde de ekliyorum dosya halinde de.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Dim Baglanti, sorgu, rs As Object, xx As Variant, yy As Long, ilk As Long

 
Function verigetir(aaa As Variant)
 
    Set Baglanti = CreateObject("Adodb.connection"): Set rs = CreateObject("Adodb.recordset")
    dosyayolu = ThisWorkbook.Path & "\kapalı.xlsx"
    Baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosyayolu & ";extended properties=""excel 12.0;hdr=no"""
    sorgu = "SELECT count(f1) FROM [FaturaListesi$A2:I1048576]"
    rs.Open sorgu, Baglanti, 1, 1
    
    
 If rs.RecordCount > 0 Then aaa = rs(0).Value


End Function
Sub Veri_Aktar()
Dim Kayit As Integer
Range("A5:L65000").ClearContents
xx = verigetir(aaa)
yy = aaa + 1 ' 1 in sebebi 2.satirdan baslandigi icin.

Sonsatir = yy
[r2] = WorksheetFunction.RoundUp((yy - 1) / 20, 0) - 1

i = [O2] * 20
Kayit = [O2]

    Kayit = Kayit + 1
    Set Con = CreateObject("Adodb.Connection"):  Set rs = CreateObject("Adodb.RecordSet")
        Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\kapalı.xlsx" & ";extended properties=""excel 12.0;hdr=no;imex=1"""
    
       sorgu = "Select f1,f3,'',f4,'',f6,f8,'',f12 from [FaturaListesi$A" & i & ":L" & i + 20 & "]"" ' where f3 = '" & Range("N2").Value & "'"
 
        rs.Open sorgu, Con, 1, 1
        Range("a5").CopyFromRecordset rs
         rs.Close: Con.Close
         Set Con = Nothing: Set rs = Nothing: sorgu = Empty
 
End Sub
Sub Cvs_Kaydet()
 ActiveWorkbook.SaveAs Filename:= _
          ThisWorkbook.Path & "\KAYIT - " & Kayit & ".csv", FileFormat:=xlCSV _
        , CreateBackup:=False
End Sub
Eklenmiş Dosyalar
Dosya Türü: xlsm Dosya Aktar Ayrı Kodlar.xlsm (32.7 KB, 6 Görüntülenme)
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 21-02-2017, 17:55   #9
Filose
Altın Üye
 
Filose kullanıcısının avatarı
 
Giriş: 22/10/2012
Şehir: Trabzon
Mesaj: 195
Excel Vers. ve Dili:
Office 2013 Türkçe
Varsayılan

Sayın Askm,

İlginize çok teşekkür ederim. Verileri getiren kodlar tamam. Yalnız 2. satırdan başlaması için ben düzelttim.
Kapalı dosyadan gelen verilerin tamamı gelmesi gerekiyordu. Onu şöyle yaptım.
Range("A2:L65000").ClearContents ve
....
sorgu = "Select f1,f3,'',f4,'',f6,f8,'',f12 from [FaturaListesi$A" & i & ":L" & i + 65000 & "]"" ' where f3 = '" & Range("N2").Value & "'"
.....
Range("a2").CopyFromRecordset rs

olarak değiştirdim. Ancak ilk 60 satır gelmedi.

1. Kapalı dosyadan tüm satırlar gelmesi gerekiyor. (20'şer satır değil)
2. Veriler geldikten sonra gelen sütunlar olduğu gibi AYNI SÜTUNLARA CSV olarak, kayt etmesi gerekir. (Tek satıra yazıyor.)

Çok teşekkür ederim, ellerinize sağlık.
Filose Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-02-2017, 21:10   #10
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 860
Excel Vers. ve Dili:
2010-2016
Varsayılan

Kodlara tekrar sabah bakarım. Siz ilk mesajhınızda "CSV olarak 20'şer satır olarak ayrı ayrı bir klasörün içine kayıt etsin." dediğiniz için 20 şer satır aldırıyorum verileri. Bu dediğiniz daha kolay. İstediğiniz hali ile sabah tekrar ekleme yaparım inşallah.
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 20:59


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu osgb - Lingerie - Dyeing Machine - Çorlu Temizlik- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Burun Estetiği- Çorlu Pimapen- Karton Bardak- Marka Tescil Danışmanlık- Marmara Ereğlisi Restaurant- Çorlu Baskı- Çorlu Sigorta- Çorlu Pimapenci- İstanbul Avukat-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden