Kapalı dosyaya bilgi aktar.

[sedat2161]

Ekli 1 numaralı dosyamdan I,J,K,L sütunlardaki bilgileri 2 numaralı dosyadaki c,d,e,f sütunlarına aktarmak istiyorum. Yardımcı olursanız çok memnun olurum.
Not: 2 Numaralı dosya Excel dosyası değil ne olduğunu bilemiyorum. Oradan Programa aktarma yapıyoruz. Şu ana kadar kopyala yapıştır şeklinde yapıyordum.

 

[sedat2161]

2 numaralı dosya uzantısı uygun olmadıpından yükleyemedim dosya resmi bu şekilde

 

[Haluk]

O dosya CSV dosyası.... "Zip/Rar" ile sıkıştırıp, ekleyebilirsiniz...

.

 

[sedat2161]

O dosya CSV dosyası.... "Zip/Rar" ile sıkıştırıp, ekleyebilirsiniz...

.

Bilgilendirmeniz ,ç,n teşekkür ederim Haluk bey. Dosyayı ekledim yardımlarınızı bekliyorum. Hayırlı akşamlar.

 

[leonadies]

Benzer bir soru bende sormuştum ama yanıt alamadım forumdan. Haluk üstadımız buraya cevap verirse benimde çözüm sağlanmış olur hemen uyarlarım inş

 

[sedat2161]

Bilgilendirmeniz ,ç,n teşekkür ederim Haluk bey. Dosyayı ekledim yardımlarınızı bekliyorum. Hayırlı akşamlar.

Hayırlı akşamlar arkadaşlar. Bu sorunun bir çözümü yokmu acaba. Yoksa boşuna takip etkiyeyim. Bilgisi olan arkadaşlar yazsa çok memnun olurum. Iyi çalışmalar.

 

[Korhan Ayhan]

Deneyiniz.

İki dosyada aynı klasörde olmalıdır.

Option Explicit

Sub Verileri_Aktar()
    Dim Dosya_Sistemi As Object, Yol As String, Dosya As Object
    Dim All_Text As Variant, All_Text_Detay As Variant, Son As Long
    Dim X As Long, Say As Byte, Ad As String, Bul As Range, Adres As String

    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")

    Yol = ThisWorkbook.Path & Application.PathSeparator & "2.csv"

    Set Dosya = Dosya_Sistemi.OpenTextFile(Yol, 1)
    All_Text = Dosya.ReadAll
    Dosya.Close

    All_Text = Split(All_Text, vbNewLine)

    For X = 1 To UBound(All_Text)
        If All_Text(X) <> "" Then
            All_Text_Detay = Split(All_Text(X), ";")
            Say = InStr(1, Trim(All_Text_Detay(1)), " ")
            If Say > 0 Then
                Ad = Left(Trim(All_Text_Detay(1)), Say - 1)
                Set Bul = Range("B:B").Find(Ad, , , xlPart)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If (Bul.Value & " " & Bul.Offset(0, 1).Value) = Trim(All_Text_Detay(1)) Then
                            All_Text_Detay(2) = Bul.Offset(0, 7).Value
                            All_Text_Detay(3) = Bul.Offset(0, 8).Value
                            All_Text_Detay(4) = Bul.Offset(0, 9).Value
                            All_Text_Detay(5) = Bul.Offset(0, 10).Value
                            All_Text(X) = Join(All_Text_Detay, ";")
                            Exit Do
                        End If
                        Set Bul = Range("B:B").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        End If
    Next
   
    Set Dosya = Dosya_Sistemi.OpenTextFile(Yol, 2)
    Dosya.Write Join(All_Text, vbNewLine)
    Dosya.Close

    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[sedat2161]

Deneyiniz.

İki dosyada aynı klasörde olmalıdır.

Option Explicit

Sub Verileri_Aktar()
    Dim Dosya_Sistemi As Object, Yol As String, Dosya As Object
    Dim All_Text As Variant, All_Text_Detay As Variant, Son As Long
    Dim X As Long, Say As Byte, Ad As String, Bul As Range, Adres As String

    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")

    Yol = ThisWorkbook.Path & Application.PathSeparator & "2.csv"

    Set Dosya = Dosya_Sistemi.OpenTextFile(Yol, 1)
    All_Text = Dosya.ReadAll
    Dosya.Close

    All_Text = Split(All_Text, vbNewLine)

    For X = 1 To UBound(All_Text)
        If All_Text(X) <> "" Then
            All_Text_Detay = Split(All_Text(X), ";")
            Say = InStr(1, Trim(All_Text_Detay(1)), " ")
            If Say > 0 Then
                Ad = Left(Trim(All_Text_Detay(1)), Say - 1)
                Set Bul = Range("B:B").Find(Ad, , , xlPart)
                If Not Bul Is Nothing Then
                    Adres = Bul.Address
                    Do
                        If (Bul.Value & " " & Bul.Offset(0, 1).Value) = Trim(All_Text_Detay(1)) Then
                            All_Text_Detay(2) = Bul.Offset(0, 7).Value
                            All_Text_Detay(3) = Bul.Offset(0, 8).Value
                            All_Text_Detay(4) = Bul.Offset(0, 9).Value
                            All_Text_Detay(5) = Bul.Offset(0, 10).Value
                            All_Text(X) = Join(All_Text_Detay, ";")
                            Exit Do
                        End If
                        Set Bul = Range("B:B").FindNext(Bul)
                    Loop While Not Bul Is Nothing And Bul.Address <> Adres
                End If
            End If
        End If
    Next
  
    Set Dosya = Dosya_Sistemi.OpenTextFile(Yol, 2)
    Dosya.Write Join(All_Text, vbNewLine)
    Dosya.Close

    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

Hayırlı sabahlar arkadaşlar. Korhan Hocam çok sağ olun sorunum ile ilgilendiniz ve aktarma oluyor. Yalnız bir sorunum var 2 numaralı csv dosyam Yerel disk D de bulunuyor. 1 numaralı dosyam masa üstünde. Program sadece D den 2 numaralı CSV dosyasından bilgi çekiyor. 1 numaralı dosya masa üstünde 2 numaralı dosya D de olacak şekilde ayarlanabilir mi . Şimdiden herkese çok teşekkür ediyor iyi çalışmalar diliyorum.

 

[Korhan Ayhan]

Kod içinde Yol değişkeni var. Bu bölüme csv dosyanızı tam yoksunu yazıp deneyiniz.

Örnek;

Yol = "D:\2.csv"

 

[sedat2161]

Kod içinde Yol değişkeni var. Bu bölüme csv dosyanızı tam yoksunu yazıp deneyiniz.

Örnek;

Yol = "D:\2.csv"

Hocam yolların yanına "D:\2.csv" ekledim bu şekilde uyarı çıktı. Yardımcı olabilirmisiniz.

 

[Korhan Ayhan]

Sadece hata veren bölümü eski haline alıp deneyiniz.

 

[sedat2161]

Sadece hata veren bölümü eski haline alıp deneyiniz.

Hocam yine hata verdi

 

[Korhan Ayhan]

Kod içinde sadece "Yol =" ile başlayan satırı aşağıdaki gibi değiştirip kodu deneyiniz.

Yol = "D:\2.csv"

 

[sedat2161]

Kod içinde sadece "Yol =" ile başlayan satırı aşağıdaki gibi değiştirip kodu deneyiniz.

Yol = "D:\2.csv"

Hayırlı sabahlar. Korhan AYHAN hocam çok teşekkür ederim. emeğinize sağlık. ALLAH razı olsun. Kodu doğru yere uyarlayınca oluyormuş. Hakkınızı helal edin. İyi çalışmalar diliyorum.