Farklı dosyalarda verileri tek dosyada toplama

[reXus]

Merhabalar,

Projelerimizde süreçlerin ortalama zaman dağılımını görebilmek için uzun varli bir database oluşturmak adına bir çalışma başlattık. Bunun içinde ofisteki 10 çalışanın günde projeler için ayırdıkları zamanı bir tabloya işlemelerini istedik. Tablo basitçe proje adı, parsonel adı, harcadığı süre ve süreç numarası bilgilerini içeriyor. Fakat 10 kişinin bu verileri tek dosyaya girmesi ortalama 15 dakikadan 150 dakika sürüyor. Dosya ortak olduğu için sürekli kullanımda oluyor, diğer kişiler veri girişi yapamıyor.

Biz her personel için kişisel bir dosya oluşturup girilen verileri tek bir ana dosyada görmeyi istiyoruz. Bu konuda yardımınızı rica ediyorum.

Şimdiden teşekkürler.

 

[reXus]

yardımcı olabilecek var mı?

 

[Huseyinkis]

yardımcı olabilecek var mı?

ekteki kodlarla YOL kısmında belirtilen klosorun içindeki excel dosyalarını açarak sayfa1 de bulunan A1 ile Z65536 satırlar arasından dolu olanları alır ve sizin oluşturacağınız dosyanın içine alt alta kopyalar.

dosya için yapmanız gereken yeni bir excel dosyası oluşturup kod kısmına bunu ekleyin dosyanızın isminide aşağıdaki Windows("Birlestirme.xlsm").Activate formulunun içine yazın benim dosyanın ismi Birlestirme.xlsm

2. olarak dosyaların bulunduğu klosoru Yol kısmınına tanımlayın ve çalıştırın.

Sub Tekliste()
    Dim Yol As String, Dosya As String
    Dim K2 As Workbook
    On Error Resume Next
    
    Yol = "C:\Deneme\Personel\LİSTELERİMİZ\"
    Dosya = Dir(Yol & "*.xls")
    Do While Len(Dosya) > 0
    Set K2 = Workbooks.Open(Yol & Dosya, False, False)
Windows(Dosya).Activate
Sheets("Sayfa1").Select
sonsaa = Sheets("Sayfa1").Range("F65536").End(3).Row
Sheets("Sayfa1").Range("A1:Z" & sonsaa).Select
Selection.Copy
Windows("Birlestirme.xlsm").Activate
huseyin = Sheets("Sayfa2").Range("C655536").End(3).Row + 1
Sheets("Sayfa2").Select
Sheets("Sayfa2").Cells(huseyin, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
    K2.Close True
    Dosya = Dir()
Loop
End Sub

 

[mk39832]

Merhabalar,

ek'tei kodu kullandım fakat çalıştıramadım, yardımcı olabilirmisiniz,

 

[reXus]

Aynen bende çalıştıramadım. Makro kodlamayı hiç bilmiyorum diyebilirim. Sadece tahmini olarak aşağıdakileri yaptım.

sk.xls, ao.xls, yb.xls adında 3 dosya oluşturdum. birde tablo.xlsm (tüm veriler bu dosyada toplanacak)

tablo.xlsm i açtım. sayfa1 de kodlama sayfasını açıp aşağıdaki kodları ekledim. kodları kendimce doğru olacağını düşündüğüm şekilde düzenledim ama çalışmadı. muhtemelen yapılması gerekenleri tam olarak yapamadım. yardımcı olursanız sevinirim.

Yapmak istediğim sk.xls, ao.xls, yb.xls dosyalarına girilen verilerin tümünün tablo.xlsm dosyası açıldığında burada alt alta eksiksiz olarak görünmesi.

Sub Tekliste()
Dim Yol As String, Dosya As String
Dim K2 As Workbook
On Error Resume Next

Yol = "\\ns41\ortak\excel" (Ağ uzantısı)
Dosya = Dir(Yol & "*.xls")
Do While Len(Dosya) > 0
Set K2 = Workbooks.Open(Yol & Dosya, False, False)
Windows(Dosya).Activate
Sheets("Sayfa1").Select
sk = Sheets("Sayfa1").Range("F65536").End(3).Row
Sheets("Sayfa1").Range("A1:Z" & sk).Select
Selection.Copy
Windows("tablo.xlsm").Activate
ao = Sheets("Sayfa2").Range("C655536").End(3).Row + 1
Sheets("Sayfa1").Select
Sheets("Sayfa1").Cells(ao, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
K2.Close True
Dosya = Dir()
Loop
End Sub