• DİKKAT

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

Kapalı dosyadan veri alma

O

ozuberk

Katılım
10 Ağustos 2004
Mesajlar
292
Excel Vers. ve Dili
Excel 2021 - Türkçe
Merhaba,

"Kapalı.xls" sayfasından "Açık.xls" olan sayfaya veri almak istiyorum. Kapalı.xls dosyasında verilen değişken olabilir. Örneğin 10 adet veride olabilir veya 1000 adet de veri olabilir.

Not: Dosyalar masa üstünde

Teşekkürler
 

Ekli dosyalar

Dosyanız ektedir.
her 2 dosyada ayni klasörde olmalıdır.:cool:
Kod: 
Sub kapali_aktar()
Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\kapalı.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Kapalı$];", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.movefirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

Evren bey peki bu dosyada tarihe göre veri aktarma mümkümmüdür örn; bir hücreye tarih yazalım o tarihteki bilgileri açık olan dosyaya aktarsın olabilirmi?
 
tamer060' Alıntı:
Evren bey peki bu dosyada tarihe göre veri aktarma mümkümmüdür örn; bir hücreye tarih yazalım o tarihteki bilgileri açık olan dosyaya aktarsın olabilirmi?
Genişletmek için tıkla ...
Bana yolladığınız dosyada tarih sütunu yoktu?
Dosyaları düzenleyip o şekli ile yollayın.:cool:
 
Evren Bey Soruyu ben göndermedim ama tarihte olursa benim işimede yarqayacak biazda bişeyler öğrenmiş olacağım ilgini için teşekkür ederim dosya ektedir. tarih kısmına yazdığım tarihte olan verile kapalı dosyadan alıp açık dosyaya aktarsın. olabilirmi?
 
Son düzenleme:
tamer060' Alıntı:
Evren Bey Soruyu ben göndermedim ama tarihte olursa benim işimede yarqayacak biazda bişeyler öğrenmiş olacağım ilgini için teşekkür ederim dosya ektedir. tarih kısmına yazdığım tarihte olan verile kapalı dosyadan alıp açık dosyaya aktarsın. olabilirmi?
Genişletmek için tıkla ...
Dosya ektedir.:cool:
Kod: 
Sub kapali_aktar()
Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\kapalı.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Kapalı$] [B][COLOR="Red"]where Deneme1=" & CDbl(Range("B1").Value) &[/COLOR][/B] ";", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.movefirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

Evren Bey,

Tarihler H sutununda ise nasıl yaparık.
 
ozuberk' Alıntı:
Evren Bey,

Tarihler H sutununda ise nasıl yaparık.
Genişletmek için tıkla ...
Ekli dosyayı inceleyiniz.:cool:
Kod: 
Sub kapali_aktar()
Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\kapalı.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Kapalı$] [B][COLOR="Red"]where Tarih=" & CDbl(Range("B1").Value) &[/COLOR][/B] ";", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.movefirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

Evren bey çok teşekkür ederim. Ellerinize sağlık, iyi akşamlar.
 
evren bey bir konu açtım mantıksal veri kaydetme adı altında bakabilirmisiniz yapılabilirmi?
 
Evren bey aşağıdaki kodu çalıştırdığımda hata veriyor. Daha önceki kod da xls formatındaydı csv yapınca hata verdi. Konu hakkında yardımlarınızı rica ederim.




Sub gelenisaktar_aktar()

temizle_gelenisler

Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\GELEN İŞLER.csv;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [GELEN İŞLER$] where Tarih=" & CDbl(Range("I1").Value) & ";", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.MoveFirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"Hukuk Müşavirliği", vbOKOnly + vbInformation, "Özgür"
End Sub

Sub temizle_gelenisler()

Sheets("Sorgu").Select

Range("A2:AA65536").ClearContents

Range("A1").Select

End Sub
 
ozuberk' Alıntı:
Evren bey aşağıdaki kodu çalıştırdığımda hata veriyor. Daha önceki kod da xls formatındaydı csv yapınca hata verdi. Konu hakkında yardımlarınızı rica ederim.




Sub gelenisaktar_aktar()

temizle_gelenisler

Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\GELEN İŞLER.csv;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [GELEN İŞLER$] where Tarih=" & CDbl(Range("I1").Value) & ";", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.MoveFirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"Hukuk Müşavirliği", vbOKOnly + vbInformation, "Özgür"
End Sub

Sub temizle_gelenisler()

Sheets("Sorgu").Select

Range("A2:AA65536").ClearContents

Range("A1").Select

End Sub
Genişletmek için tıkla ...

bana excel dosyanızı ve csv formatlı dosyanızı yollayın bir bakayım.:cool:
 
Aşağıdaki kodla csv dosyadan veri aldım
Sizde dodya adını ve yolunu isterseniz değiştirerek verileri alabilirsiniz.:cool:
Her 2 dosyada ayni klasörde olamlıdır.:cool:
Kod: 
Sub csv_aktar()
Dim sat As Long, deg, k As Integer
Range("A1:K65536").ClearContents
Open (ThisWorkbook.Path & "\aaa.csv") For Input As #1
Do While Not EOF(1)
    Line Input #1, a
    deg = Split(a, ";")
    sat = sat + 1
    For k = LBound(deg) To UBound(deg)
        Cells(sat, k + 1).Value = deg(k)
    Next
Loop
Close #1
End Sub
 
Buda makro kaydet yöntemini kullanrak bulduğum kodlar.
Dış veri al kullanarak bu kodlara makro kaydet yöntemi ile ulaştım.:cool:
Kod: 
Sub CSV_VERI_ALL()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Documents and Settings\aaa\Desktop\aaa.csv", Destination:=Range("A1" _
        ))
        .Name = "aaa_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 857
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub
 
Dosyalar ektedir.:cool:
Kod: 
Sub csv_aktar()
Dim sat As Long, deg, k As Integer
Range("A3:IV65536").ClearContents
sat = 3
Open (ThisWorkbook.Path & "\GELEN İŞLER.CSV") For Input As #1
Do While Not EOF(1)
    Line Input #1, a
    deg = Split(a, ";")
    If UBound(deg) >= 7 Then
        If IsDate(deg(7)) Then
            If Range("H1").Value = CDate(deg(7)) Then
                For k = LBound(deg) To UBound(deg)
                    Cells(sat, k + 1).Value = deg(k)
                Next
            sat = sat + 1
            End If
        End If
    End If
Loop
Close #1
End Sub
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst