Klasörde Bulunan Bilgileri Aktarma

[gicimi]

Merhaba,

Klasör içerisinde 01.01.2... - 02.01.2... şeklinde farklı farklı 35 adet çalışma sayfaları mevcut. Tüm sayfaların 1.nci sütunlarının başlıkları aynıdır.

Tüm çalışma sayfaları açık ve/veya kapalı durumda iken, Yeni bir çalışma sayfasına dosya içerisindeki çalışma sayfalarının F-G sütunlarında bilgi var ise yeni açılan çalışma sayfasına klasör de bulunan sayfaların tüm bilgilerini aktarsın.

http://s3.dosya.tc/server5/cuuqxb/Yeni_Microsoft_Excel_Calisma_Sayfasi__3_.xlsx.html

Teşekkür Ederim...

 

[gicimi]

Arkadaşlar yardımcı olabilir misiniz_?

 

[PLİNT]

Merhaba
Bilgiler ilgili dosyaların sadece ilk sayfasında (Sayfa1) ise aşağıdaki gibi deneyiniz.

http://s3.dosya.tc/server5/0frdiu/deneme.zip.html

  Private Sub CommandButton1_Click()
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\dosyalar")
Set dc = f.Files
For Each DOSYA In dc
hzrow = 0
Set Aç = New Excel.Application
Aç.Workbooks.Open DOSYA
Set hz = Aç.Workbooks(Dir(DOSYA))
On Error Resume Next
hz.Sheets("Sayfa1").Range("f2:g" & hz.Sheets("Sayfa1").Cells(hz.Sheets("Sayfa1").Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
If Err > 0 Then: Err = 0: GoTo bl
hzrow = hz.Sheets("Sayfa1").Cells(hz.Sheets("Sayfa1").Rows.Count, 1).End(xlUp).Row
Range(Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row + hzrow - 1, 12)).Value = _
hz.Sheets("Sayfa1").Range(hz.Sheets("Sayfa1").Cells(2, 1), _
hz.Sheets("Sayfa1").Cells(hzrow, 12)).Value
bl:
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing
Next

End Sub

 

[gicimi]

Merhaba
Bilgiler ilgili dosyaların sadece ilk sayfasında (Sayfa1) ise aşağıdaki gibi deneyiniz.

http://s3.dosya.tc/server5/0frdiu/deneme.zip.html

  Private Sub CommandButton1_Click()
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(ThisWorkbook.Path & "\dosyalar")
Set dc = f.Files
For Each DOSYA In dc
hzrow = 0
Set Aç = New Excel.Application
Aç.Workbooks.Open DOSYA
Set hz = Aç.Workbooks(Dir(DOSYA))
On Error Resume Next
hz.Sheets("Sayfa1").Range("f2:g" & hz.Sheets("Sayfa1").Cells(hz.Sheets("Sayfa1").Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
If Err > 0 Then: Err = 0: GoTo bl
hzrow = hz.Sheets("Sayfa1").Cells(hz.Sheets("Sayfa1").Rows.Count, 1).End(xlUp).Row
Range(Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row + hzrow - 1, 12)).Value = _
hz.Sheets("Sayfa1").Range(hz.Sheets("Sayfa1").Cells(2, 1), _
hz.Sheets("Sayfa1").Cells(hzrow, 12)).Value
bl:
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing
Next

End Sub

Merhaba uğraşınız için tşk ederim ancak çalışmadı. yardımcı olur musunuz_?

 

[PLİNT]

Merhaba
Önceki mesajımda aşağıdaki linkte ekli; örnekte sorun çıkmıyor.
http://s3.dosya.tc/server5/0frdiu/deneme.zip.html

Merhaba,

Klasör içerisinde 01.01.2... - 02.01.2... şeklinde farklı farklı 35 adet çalışma sayfaları mevcut.

İlk mesajınızda bahsettiğiniz bilgilerin alınacağı çalışma sayfalarından; bir örnek
eklermisiniz?

 

[gicimi]

Merhaba
Önceki mesajımda aşağıdaki linkte ekli; örnekte sorun çıkmıyor.
http://s3.dosya.tc/server5/0frdiu/deneme.zip.html



İlk mesajınızda bahsettiğiniz bilgilerin alınacağı çalışma sayfalarından; bir örnek
eklermisiniz?

Merhaba,

http://s6.dosya.tc/server3/ozqyja/01.10.2015.xlsx.html
Her sayfa ekteki gibi dosya içerisinde toplamda 31 adet aynı excel çalışma sayfası bulunacak. 01.10... 02.10..... gibi, örnekte yer alan 0093 0016 ve 0093 0008 yazan yerleri aktarmasını istiyorum. Teşekkür ederim.

 

[PLİNT]

Merhaba,

http://s6.dosya.tc/server3/ozqyja/01.10.2015.xlsx.html
Her sayfa ekteki gibi dosya içerisinde toplamda 31 adet aynı excel çalışma sayfası bulunacak. 01.10... 02.10..... gibi, örnekte yer alan 0093 0016 ve 0093 0008 yazan yerleri aktarmasını istiyorum. Teşekkür ederim.

Merhaba
Ek dosyayı inceleyiniz.
http://www.dosya.tc/server4/y6l27t/deneme.zip.html
veya
http://www.yukletr.com/download.php?file=00637bbec2c533fe0aa9e3493d1ca167

[SIZE="2"]Private Sub CommandButton1_Click()
Dim a, c As Object, x, f As String
Dim i, n As Long, dosya As Integer
Sheets("veri").Select
Range("A2:L" & Rows.Count).ClearContents
i = 2
Set a = CreateObject("adodb.connection")
Set c = CreateObject("adodb.recordset")
f = ThisWorkbook.Path & "\dosyalar\"
x = Dir(f & "*.xlsx")
Application.ScreenUpdating = False
For n = 1 To CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\dosyalar").Files.Count
If x <> "" Then
a.Open "provider=microsoft.ace.oledb.12.0;data source=" & f & x & ";extended properties=""excel 12.0;hdr=yes;imex=1"""
c.Open "select * from [Sayfa1$];", a, 1, 1
 Range("A" & i).CopyFromRecordset c
 i = Cells(Rows.Count, "A").End(xlUp).Row + 1
 c.Close: a.Close: x = Dir
dosya = dosya + 1
End If: Next
Set c = Nothing: Set a = Nothing
Columns("f:g").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("I:I").NumberFormat = "[$-F400]h:mm:ss AM/PM"
Application.ScreenUpdating = True
MsgBox "VERİ ALINAN DOSYA ADEDİ : " & dosya
End Sub[/SIZE]

 

[gicimi]

Merhaba
Ek dosyayı inceleyiniz.
http://www.dosya.tc/server4/y6l27t/deneme.zip.html
veya
http://www.yukletr.com/download.php?file=00637bbec2c533fe0aa9e3493d1ca167

[SIZE="2"]Private Sub CommandButton1_Click()
Dim a, c As Object, x, f As String
Dim i, n As Long, dosya As Integer
Sheets("veri").Select
Range("A2:L" & Rows.Count).ClearContents
i = 2
Set a = CreateObject("adodb.connection")
Set c = CreateObject("adodb.recordset")
f = ThisWorkbook.Path & "\dosyalar\"
x = Dir(f & "*.xlsx")
Application.ScreenUpdating = False
For n = 1 To CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path & "\dosyalar").Files.Count
If x <> "" Then
a.Open "provider=microsoft.ace.oledb.12.0;data source=" & f & x & ";extended properties=""excel 12.0;hdr=yes;imex=1"""
c.Open "select * from [Sayfa1$];", a, 1, 1
 Range("A" & i).CopyFromRecordset c
 i = Cells(Rows.Count, "A").End(xlUp).Row + 1
 c.Close: a.Close: x = Dir
dosya = dosya + 1
End If: Next
Set c = Nothing: Set a = Nothing
Columns("f:g").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("I:I").NumberFormat = "[$-F400]h:mm:ss AM/PM"
Application.ScreenUpdating = True
MsgBox "VERİ ALINAN DOSYA ADEDİ : " & dosya
End Sub[/SIZE]

Emeğinize ve ilginize teşekkür ederim şimdi çalışıyor. Fakat 0093 008 ve 0093 0016 yazanların aktarılmasını istiyorum 0093 0003 vb. anasayfaya aktarılmasını istemiyorum. Bu işlem hakkında da yardımınızı bekliyorum.

 

[Korhan Ayhan]

Lütfen gereksiz alıntı yapmamaya dikkat ediniz.

Mesajlarınızı düzenlerseniz sevinirim.