Klasörden Dosya Seçip Açarak veri kopyalama

T

toybuklu

Katılım
22 Ekim 2009
Mesajlar
151
Excel Vers. ve Dili
2007&2010
Merhaba Saygıdeğer Hocalarım ve Arkadaşlar..

Şöyle bir talebim var yapılabilir umarım..

Makro Aşağıdaki resimdeki gibi yolu belli bir klasör var ve bu klasör içerisine günlük düşen ve adı tarih bazında değişken dosyalar var .

Amacım macro çalışsın bir pencere de tarih sorsun yada başak şekilde olabilir o tarih ile başlayan (ör:20130619)dosyayı açsın içindeki sadece belli başlıkları kopyalasın Macro çalıştırılacak dosya olan Toplu_Liste dosyasına her çalıştırıldığında data sheetinde en altına yapıştırarak kaydederek devam etsin. En Son satırda bulunan dosya adı alanınada kopyalanan verinin hangi dosyadan kopyalandığını yazsın..(Dosya adı)

Amaç hergün düşen bu dosyaları 1 dosyada toparlamak ve saklamak çünkü hergün bir veya birden fazla dosya düşmekte bunlarda sonrasında çalışma yapmak zor bu sebeple 1 dosyada toplamak istiyorum.

Dosya formatı standart bu sebeple hep aynı kolonlardaki veriler kopyalanacak.

kopyalanacak başlıkları sarı ile renklendirdim.

Yardım desteklerinizi rica ederi. şimdiden Teşekkür Ederim.

Not: Aynı güne ait birden fazla dosya olabilir bu sebple bir döngü ile o güne ait tüm dosyaları kopyalamalı..

Dosyalar ve örnek klasör ektedir.

 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu işlemler oldukca zahmetli ve baya emek isteyen işler

Aşağıdaki kod klasörün içindeki dosyalardaki ilgili sütünlardaki verileri kopyalıyarak alıyor.

Sizin yapmanız gereken iş aynı güne ait işlemleri bir klasörde toplamak

kod:

Kod: 
Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub Dosya_Listele()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

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

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Range("A1").Select
Application.ScreenUpdating = False

Liste (Kaynak)
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "işlem tamam"


Set Klasor = Nothing

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, r As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files

Set fk = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fs

uzanti = fk.GetExtensionName(Dosya)

deg = 0
If ThisWorkbook.Name <> Dosya.Name Then

If Val(Application.Version) > 11 Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Then
deg = 1
End If
Else
If uzanti = "xls" Then
deg = 1
End If
End If

If deg = 1 Then
Set wb = Workbooks.Open(Dosya)
yenidosya_adı = ActiveWorkbook.Name
For r = 1 To Sheets.Count

Sheets(r).Select
yeniSayfa_adı = ActiveSheet.Name
sat1 = WorksheetFunction.CountA(Worksheets(Sheets(r).Name).Range("A2:A5000")) + 1
sut1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "a").End(3).Row + 2

ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 8).Value = Kaynak
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 9).Value = Dosya.Name
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 10).Value = yeniSayfa_adı


If sat1 > 1 Then
Worksheets(Sheets(r).Name).Range("A2:C" & sat1 & ",G2:G" & sat1 & ",I2:I" & sat1 & ",K2:K" & sat1 & ",L2:L" & sat1).Copy
End If
Windows(dosya_adı).Activate
If sat1 > 1 Then
Range("a" & sut1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

If ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 1).Value = "" Then
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 8).Value = ""
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 9).Value = ""
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 10).Value = ""
End If

Windows(yenidosya_adı).Activate

Next r

Application.CutCopyMode = False
wb.Close False
Application.Visible = True

End If
End If
Next

On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
T

toybuklu

Katılım
22 Ekim 2009
Mesajlar
151
Excel Vers. ve Dili
2007&2010
Emeğinize teşekkürler aslında ilgili klasöre müdehale imkanımız alanda sadece görüntüleme yapabiliyoruz bu sebeple dosyaları klasörleyemiyorum. Eğer uğraştıracak bir iş ise yormakta istemem sizi.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
toybuklu' Alıntı:
Emeğinize teşekkürler aslında ilgili klasöre müdehale imkanımız alanda sadece görüntüleme yapabiliyoruz bu sebeple dosyaları klasörleyemiyorum. Eğer uğraştıracak bir iş ise yormakta istemem sizi.
Genişletmek için tıkla ...
Ben ne demek istediğinizi anlayamadım yukarıdaki kodu çalıştırınca klasörün içindeki dosyalardan verileri kopyalayarak getirmiyormu.
 
T

toybuklu

Katılım
22 Ekim 2009
Mesajlar
151
Excel Vers. ve Dili
2007&2010
Kodlar çok iyi çalışıyor demek istediğim siz demişsiniz ya "Sizin yapmanız gereken iş aynı güne ait işlemleri bir klasörde toplamak" diye bunu yapamıyorum klasör altındaki dosyaları sadece açıp görüntüleme yetkim var dosyları komple başka bir yere kopyalama yada klasöre taşıma yetkim yok klasör önrnek olarak vermiştim. Normade ortak bir alanda bulunan klasör altında bu dosylara bu sebeple benim belriteceğim örn 20130619 ile başlayan dosyları açması ve bu işlemleri yapması.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod:

Kod: 
Dim Kaynak As String
Dim Sayfa_Adı As String
Dim dosya_adı As String
Dim aranan As String


Sub Dosya_Listele()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

aranan = InputBox("Veri Alınacak Dosya adını yazın.", "Dosya adı", "20130619")

If aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

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

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Range("A1").Select
Application.ScreenUpdating = False

Liste (Kaynak)
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "işlem tamam"


Set Klasor = Nothing

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, r As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files

Set fk = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fs

uzanti = fk.GetExtensionName(Dosya)
deg = 0

If aranan = Mid(Dosya.Name, 1, Len(aranan)) Then

If ThisWorkbook.Name <> Dosya.Name Then


If Val(Application.Version) > 11 Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Then
deg = 1
End If
Else
If uzanti = "xls" Then
deg = 1
End If
End If

If deg = 1 Then
Set wb = Workbooks.Open(Dosya)
yenidosya_adı = ActiveWorkbook.Name
For r = 1 To Sheets.Count

Sheets(r).Select
yeniSayfa_adı = ActiveSheet.Name
sat1 = WorksheetFunction.CountA(Worksheets(Sheets(r).Name).Range("A2:A5000")) + 1
sut1 = ThisWorkbook.Sheets(Sayfa_Adı).Cells(Rows.Count, "a").End(3).Row + 2

ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 8).Value = Kaynak
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 9).Value = Dosya.Name
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 10).Value = yeniSayfa_adı


If sat1 > 1 Then
Worksheets(Sheets(r).Name).Range("A2:C" & sat1 & ",G2:G" & sat1 & ",I2:I" & sat1 & ",K2:K" & sat1 & ",L2:L" & sat1).Copy
End If
Windows(dosya_adı).Activate
If sat1 > 1 Then
Range("a" & sut1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

If ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 1).Value = "" Then
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 8).Value = ""
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 9).Value = ""
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut1, 10).Value = ""
End If

Windows(yenidosya_adı).Activate

Next r

Application.CutCopyMode = False
wb.Close False
Application.Visible = True

End If
End If
End If
Next

On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
T

toybuklu

Katılım
22 Ekim 2009
Mesajlar
151
Excel Vers. ve Dili
2007&2010
ÇOK ÇOK Teşekkürler..

Çok Çok Saolun... Tam istediğim Gibi Oldu.. Fazla olmaz isem bir ufak özellik daha siteyeceğim..
En Sona dosya adı ve yolu yazıyor ya onu tek satıradeğil o dosyadan kopyalanan tün satırların sonuna yazsın mümkünse..

Birde ayrı bir rica olarak bu çalışmadan bağımsız bu çalışmadaki klasör seçme özelliğiyle birlikte seçilen klasör içindeki tüm dosyların isimlerini bir sheete yazsın (Burası değişken olabileceğinden listelemesi lazım dosya adı ve sayısı artabilir eksilebilir.) yukardan aşağıya yanlarınada dosyaların açık yada kapalı olduğunu yazsın . dosya açık ise dosya adının yanında dosya açık yazssın.

Sonra tüm dosyalar kapalı ise bu dosyaların içindeki bilgilerin tamamını kopyalasın önceki yaptığınız çalışmadaki gibi macronun çalıştığı dosyada RİM sheetine alt alta yapıştırsın yine sonuna kopyalama yaptığı dosyanın adını yazsın Kopayalama yaptığı dosyada kopyalanan tüm alanı silsin ve dosyayı kapatıp bunu tü dosyalarda yapsın. :) ... ÇOK ÇOK TEŞEKKÜRLERİMLE ... SAYGILAR SUNARIM..

Macronun çalışacağı dosya ve klasör içeriğini ekte bulabilirsiniz.
 

Ekli dosyalar

Son düzenleme:
T

toybuklu

Katılım
22 Ekim 2009
Mesajlar
151
Excel Vers. ve Dili
2007&2010
Eğer Bunlar çok zaman alır derseniz sadece Dosyaların listelenmesi ve açık kapalı durumlarının yazılması macrosu yapılabilirmi..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst