Ftp dosyasından excele veri aktarım...

[f_alkan]

5 adet txt dosyasını excel satırına noktalı virgül ( ayırarak atmasını
ama 5 adet txt dosyasını tek bir excel sayfasına atmasını istiyorum.
ilgilenen arkadaşlara tşk ederim. hayırlı çalışmalatr dileerim.

 

[Mahir64]

Merhaba,

Dış veri al yöntemiyle aktarabilirsiniz.

Veri / Dış veri al / Sınırlandırılmış / Noktalı virgül

 

[f_alkan]

hocam
bu şekilde dosyayı içeri alıyoruz. bir problem yok. ben bütün dosyaları aynı şekilde
aynı excel sayfasında alt alta birleştirmek istiyorum.

 

[f_alkan]

konuyla alakalı yardımcı olabilirmiyiz
acil bitirmem gereken bir işte
yardımcı olacak arkadaşlara tşk ediyorum.

 

[halit3]

5 adet txt dosyasını excel satırına noktalı virgül ( ayırarak atmasını
ama 5 adet txt dosyasını tek bir excel sayfasına atmasını istiyorum.
ilgilenen arkadaşlara tşk ederim. hayırlı çalışmalatr dileerim.

Text dosyalarını bir klasörün içine koyun ve bu kodu koyacağınız dosyada bu klasörün yanında olsun

kod;

Sub verial ()
Cells.ClearContents
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (Kaynak)
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt
Range("a1").Select
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=";", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("A:bz").EntireColumn.AutoFit
Range("A1").Select
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
If Right(yol, 1) <> "\" Then
ekle = "\"
Else
ekle = ""
End If
For Each Dosya In fs
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya.Name
son = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Dim sayfa_adi As String
Dosya = yol & ekle & Dosya.Name
If Dosya = "False" Then
Exit Sub
End If
sayfa_adi = Dir(Dosya)
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Dosya, Destination:=Range("A" & son))
.Name = sayfa_adi
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.Refresh BackgroundQuery:=False
End With
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[f_alkan]

hocam saygılar sunuyorum.koddan dolayı tşk ediyorum. boş bir excel sayfasının kod sayfasına
yazılan kodu yapıştırdım. kodu çalıştırdığımda masaüstüne gidip dosyayı buluyor fakat aktarma yaptığında "Private Sub Liste(yol As String)" sarı renkte çıkıyor.ne yapmam gerekiyor.
hocam en üstte sorumu gönderirken 5 adet txt dosyasını atmıştım.
iyi çalışmalar sunuyorum.

 

[halit3]

hocam saygılar sunuyorum.koddan dolayı tşk ediyorum. boş bir excel sayfasının kod sayfasına
yazılan kodu yapıştırdım. kodu çalıştırdığımda masaüstüne gidip dosyayı buluyor fakat aktarma yaptığında "Private Sub Liste(yol As String)" sarı renkte çıkıyor.ne yapmam gerekiyor.
hocam en üstte sorumu gönderirken 5 adet txt dosyasını atmıştım.
iyi çalışmalar sunuyorum.

dosya ekte

 

[f_alkan]

hocam tşk ederim
sağolun

 

[halit3]

hocam tşk ederim
sağolun

iyi çalışmalar