• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kapalı dosyadan bazı sütunları alıp CSV olarak kayıt etmek

Filose

Filose

Katılım
22 Ekim 2012
Mesajlar
311
Excel Vers. ve Dili
Office 2016 Türkçe
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
 

Ekli dosyalar

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.
 
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
 
Aşağıdaki kodları kullanabilirsiniz.
Kod: 
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
 
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
 
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.
 
İ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.
 
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: 
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
 

Ekli dosyalar

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.
 
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.
 
Aşağıdaki kodları deneyin.2.Sorunu anlayamadım. Bu şekilde değilse örnek ekleyip gösterebilirseniz.

Kod: 
Sub Veri_Aktar()
Range("A2:L65000").ClearContents
    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$A2:L65000]" ' where f3 = '" & Range("N2").Value & "'"
 
        rs.Open sorgu, Con, 1, 1
        Range("a2").CopyFromRecordset rs
         rs.Close: Con.Close
         Set Con = Nothing: Set rs = Nothing: sorgu = Empty
End Sub
Sub Cvs_Kaydet()
Application.DisplayAlerts = False
 ActiveWorkbook.SaveAs Filename:= _
          ThisWorkbook.Path & "\KAYIT - " & Kayit & ".csv", FileFormat:=xlCSV _
        , CreateBackup:=False
Application.DisplayAlerts = True
End Sub
 
Sayın Askm,

Aktarılan verilerde hiç bir sorun yok. Ellerinize sağlık. Sadece,

CSV kayıt için A, B, D, F, G, I sütunlarına yazılması gerekiyordu. sadece A2 sütununa tek satır olarak yazıyor.

CSV Kayıt için; A2 den başlayarak 20'şer satır olarak kayıt yapması gerekir. Bu 20 satır sorun değil 50 satırda olabilir. Ama 20. satır veya 50. satırdan sonra hiçbir şey yazmamalı çünkü; bu veriler muhasebe programına aktarılıyor.
Bunun için CSV Örnek dosya ektedir.

Tekrar çok teşekkür ederim.
Saygılar sunarım.
 

Ekli dosyalar

csv diye bir sayfa daha açın. Aşağıdaki kodlar ile önce kapalı dosyadaki tüm verileri alıyor. sonra 20 şer kayıt olarak csv sayfasına aktarıyor. çalışma kitabınızın olduğu dizinin altında "CSV KAYIT" adında bir klasör açarak csv kayıtlarını bu klasör içerisine kaydediyor.

Kod: 
Dim kaydim As Integer

Sub Veri_Aktar()
Range("A2:L65000").ClearContents
    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$A2:L65000]" ' where f3 = '" & Range("N2").Value & "'"
 
        rs.Open sorgu, Con, 1, 1
        Range("a2").CopyFromRecordset rs
         rs.Close: Con.Close
         Set Con = Nothing: Set rs = Nothing: sorgu = Empty
End Sub

Sub askm_sayfa_Aktar()

Dim s1, s2 As Worksheet, SATIR As Long, X As Long
Set s1 = Worksheets("Dosya Aktar")
Set s2 = Worksheets("csv")
Application.ScreenUpdating = False
kaydim = 0
s2.Select
With s2
.Range("A2:I65536").ClearContents

SATIR = s2.Cells(65536, 1).End(3).Row + 1

.Cells(1, 1) = "Tarih"
.Cells(1, 2) = "Evrak_No"
.Cells(1, 3) = "Açıklama"
.Cells(1, 4) = "Genel_Toplam"
.Cells(1, 5) = "Matrah"
.Cells(1, 6) = "%08_Kdv_Tutar"
.Cells(1, 7) = "%18_Kdv_Tutar"
.Cells(1, 8) = "%00_Kdv_Tutar"
.Cells(1, 9) = "%01_Kdv_Tutar"

For X = 2 To s1.Range("B65536").End(3).Row
.Cells(SATIR, 1) = s1.Cells(X, 1)
.Cells(SATIR, 2) = s1.Cells(X, 2)
.Cells(SATIR, 3) = s1.Cells(X, 3)
.Cells(SATIR, 4) = s1.Cells(X, 4)
.Cells(SATIR, 5) = s1.Cells(X, 5)
.Cells(SATIR, 6) = s1.Cells(X, 6)
.Cells(SATIR, 7) = s1.Cells(X, 7)
.Cells(SATIR, 8) = s1.Cells(X, 8)
.Cells(SATIR, 9) = s1.Cells(X, 9)
If SATIR = 21 Then
    SATIR = 2
    kaydim = kaydim + 1
    Excel_Dosyasini_Csv_Yap
    .Range("A2:I21").ClearContents
Else
    SATIR = SATIR + 1
End If
Next
End With
    kaydim = kaydim + 1
    Excel_Dosyasini_Csv_Yap
Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sub Excel_Dosyasini_Csv_Yap()
Dim i As Long
Dim dosya, bak
Application.DisplayAlerts = False
Set dosya = CreateObject("Scripting.FileSystemObject")
 

    bak = dosya.FolderExists(ThisWorkbook.Path & "\" & "CSV KAYIT")
    If bak <> True Then
        dosya.CreateFolder ThisWorkbook.Path & "\" & "CSV KAYIT"
    End If

    Dim dosyam As String
    Dim Ert As Long, son_satır As Long, kayit As Long
    son_satır = Range("A65536").End(3).Row
    dosyam = ThisWorkbook.Path & "\CSV KAYIT\KAYIT - " & kaydim & ".csv"
    
    Ert = FreeFile
    Open dosyam For Output As #Ert
        For kayit = 1 To son_satır
            If Not Cells(kayit, 1) Like " " Then
                a = Cells(kayit, 1) & vbTab
                b = Cells(kayit, 2) & vbTab
                c = Cells(kayit, 3) & vbTab
                ç = Replace(Cells(kayit, 4), ",", ".") & vbTab
                d = Replace(Cells(kayit, 5), ",", ".") & vbTab
                e = Replace(Cells(kayit, 6), ",", ".") & vbTab
                f = Replace(Cells(kayit, 7), ",", ".") & vbTab
                g = Replace(Cells(kayit, 8), ",", ".") & vbTab
                ğ = Replace(Cells(kayit, 9), ",", ".") & vbTab
               
            End If
        Print #Ert, a, b, c, ç, d, e, f, g, ğ
        Next kayit
    Close #Ert
    Set ac = Workbooks.Open(dosyam)
    ac.Sheets(1).Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, OtherChar _
        :=" ", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
    For a = 1 To Range("a65536").End(3).Row
        For b = 1 To Cells(1, Columns.Count).End(1).Column
            Cells(a, b) = Trim(Cells(a, b))
        Next b
    Next a
    Columns.AutoFit
    ac.Close
End Sub
 
Sayın Askm,
Öncelikle sizin değerli zamanını çok meşgul ettim. Ne diyeceğimi bilemiyorum. Çok çok teşekkür ederim.

Sadece; CSV dosya kayıtlarının tümünü A sütununa yazıyor. Oysa;
A,B,D,F,G,H,I sütunlarına aktarması gerekiyor. Sanırım ben tam izah edemedim kusura bakmayın. Başka sorun yok.

Saygı ve hürmetle,
 
Bu sefer tamam sanırım. Sayenizde ben de öğrenmiş oldum.
Kod: 
Dim kaydim As Integer

Sub Veri_Aktar()
Range("A2:L65000").ClearContents
    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$A2:L65000]" ' where f3 = '" & Range("N2").Value & "'"
 
        rs.Open sorgu, Con, 1, 1
        Range("a2").CopyFromRecordset rs
         rs.Close: Con.Close
         Set Con = Nothing: Set rs = Nothing: sorgu = Empty
End Sub

Sub askm_sayfa_Aktar()

Dim s1, s2 As Worksheet, SATIR As Long, X As Long
Set s1 = Worksheets("Dosya Aktar")
Set s2 = Worksheets("csv")
Application.ScreenUpdating = False
kaydim = 0
s2.Select
With s2
.Range("A2:I65536").ClearContents

SATIR = s2.Cells(65536, 1).End(3).Row + 1

.Cells(1, 1) = "Tarih"
.Cells(1, 2) = "Evrak_No"
.Cells(1, 3) = "Açıklama"
.Cells(1, 4) = "Genel_Toplam"
.Cells(1, 5) = "Matrah"
.Cells(1, 6) = "%08_Kdv_Tutar"
.Cells(1, 7) = "%18_Kdv_Tutar"
.Cells(1, 8) = "%00_Kdv_Tutar"
.Cells(1, 9) = "%01_Kdv_Tutar"

For X = 2 To s1.Range("B65536").End(3).Row
.Cells(SATIR, 1).Value = s1.Cells(X, "A").Value
.Cells(SATIR, 2).Value = s1.Cells(X, "B").Value
.Cells(SATIR, 3).Value = s1.Cells(X, "C").Value
.Cells(SATIR, 4).Value = s1.Cells(X, "D").Value
.Cells(SATIR, 5).Value = s1.Cells(X, "E").Value
.Cells(SATIR, 6).Value = s1.Cells(X, "F").Value
.Cells(SATIR, 7).Value = s1.Cells(X, "G").Value
.Cells(SATIR, 8).Value = s1.Cells(X, "H").Value
.Cells(SATIR, 9).Value = s1.Cells(X, "I").Value
If SATIR = 21 Then
    SATIR = 2
    kaydim = kaydim + 1
    Excel_Dosyasini_Csv_Yap
    .Range("A2:I21").ClearContents
Else
    SATIR = SATIR + 1
End If
Next
End With
    kaydim = kaydim + 1
    Excel_Dosyasini_Csv_Yap
Application.ScreenUpdating = True
s1.Select
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sub Excel_Dosyasini_Csv_Yap()
Dim i As Long
Dim dosya, bak
Application.DisplayAlerts = False
Set dosya = CreateObject("Scripting.FileSystemObject")
 

    bak = dosya.FolderExists(ThisWorkbook.Path & "\" & "CSV KAYIT")
    If bak <> True Then
        dosya.CreateFolder ThisWorkbook.Path & "\" & "CSV KAYIT"
    End If

    Dim dosyam As String
    Dim Ert As Long, son_satır As Long, kayit As Long
    son_satır = Range("A65536").End(3).Row
    dosyam = ThisWorkbook.Path & "\CSV KAYIT\KAYIT - " & kaydim & ".csv"
    
    Open dosyam For Output As #1
    For i = 1 To 21
        Print #1, Range("A" & i) & ";" & Range("B" & i) & ";" & Range("C" & i) & _
                   ";" & Range("D" & i) & ";" & Range("E" & i) & ";" & Range("F" & i) & ";" & Range("G" & i) & _
                    ";" & Range("H" & i) & ";" & Range("I" & i)
    Next
    Close #1

End Sub
 

Ekli dosyalar

Sayın Askm,

Hiçbir sorun yoktur. Çok çok teşekkür ederim. Ellerinize bilginize sağlık.

Saygı ve hürmetle
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst