• DİKKAT

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

Çalışma Kitabın Verilerini Birleştirme

H

htsumer

Altın Üye
Altın Üye
Katılım
7 Eylül 2004
Mesajlar
975
Excel Vers. ve Dili
Excel-2003
50 Adet Çalışma kitabının Sayfa1!indeki tüm veri formatları aynı.

50 Okul bu verileri girecek ve hepsini tek veri halde toplayarak birleştireceğim.

Bunu için makroya ihtiyacım var..K.Bakmayın hep istiyorum ama..

dosya ekte..

Ekteki dosyayı 50 okula yolladım hepsi gerekli bilgileri yazıp bana yollayacak.Bende bu verileri toplayıp tek sayfa haline alacağım..

Mesela 1 okul bana göndermiş Hayat Bilgisi 12 adet olarak, başka okul hayat bilgisi 35 tane gibi.
Ben bunları toplayıp ayrı bir çalışma kitabında Hayat Bilgisi kısmında 47 yazacağım şeklinde..
 

Ekli dosyalar

bu kodu denermisiniz.

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim baslangıc As String


Sub bul()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Range("C4:R38").ClearContents
Call Liste(Kaynak, "")
MsgBox " işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub


Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*.**" & Uzanti)
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
deg = "'" & Klasor & "\[" & Dosya & "]" & "Sheet1" & "'!R"
For s = 4 To 38
n = 1
For j = 3 To 18
Cells(s, j) = Cells(s, j) + ExecuteExcel4Macro(deg & s & "C" & j)
If Cells(s, j) = 0 Then
Cells(s, j) = ""
End If
'Cells(s, j).Select
Next j
Next s
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub
Genişletmek için tıkla ...
 
Hocam yarın mesaide deneyeceğim.Saygılar
 
Kod: 
Set fL = CreateObject("Scripting.FileSystemObject").getfold er(Klasor).SubFolders

bu hata verdi kırmızı renkte

Kod: 
Set fL = CreateObject("Scripting.FileSystemObject").getfold er(Klasor).SubFolders

bu şekilde er ibareyi kaldırdım çalıştı ama verileri toplamadı..
 
kodları buraya aktarınca wep sitesindeki kontrollerden dolayı bu kelimeyi gördüğü zaman arasını açıyor getfold er buranın birleştirilerek yazılması gerekiyor yani aradaki boşluğu kaldır
getfolder
 
Harika Halit bey tam istediğim gibi oldu Allah Razı olsun..
 
Hocam bunu başka bir excel çalışmasında denemek istediğimde değişkenler olarak örneğin ilk çalışmada 38 satır 18 sütun vardı,

Başka çalışmamda veriler 4'den 55'e kadar satır, 3 sıradan başlayan başlık 10 sütun

değişkeni
buna göremi yapacağım..
 

Ekli dosyalar

evet........
 
İlk mesajımın ekindeki çizelgede sorun yok ayrı çizelgede Hocam bir türlü birleştirmedi..Onla uğraşıom deminden beri
Dosyaya bakabilirmsiniz?
 
deg = "'" & Klasor & "\[" & Dosya & "]" & "Sheet1" & "'!R"
Genişletmek için tıkla ...

kırmızı işaratli yere sayfa ismini yazacaksınız sonraki gönderdiğin dosyada Sayfa1 yazıyor
 
Off iyicene yaşlanmışım..Sayfa1 yaptım, aksi gibi J sütunu var sizin kodda da J değişkeni kullanmışsınız temelli karıştı..Çalışıo verileri getirmio

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim baslangıc As String
 
Sub bul()
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Range("C4:j55").ClearContents
Call Liste(Kaynak, "")
MsgBox " işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
 
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*.**" & Uzanti)
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
deg = "'" & Klasor & "\[" & Dosya & "]" & "Sayfa1" & "'!J"
For s = 4 To 55
n = 1
For j = 3 To 10
Cells(s, j) = Cells(s, j) + ExecuteExcel4Macro(deg & s & "C" & j)
If Cells(s, j) = 0 Then
Cells(s, j) = ""
End If
'Cells(s, j).Select
Next j
Next s
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub
 
Oh tamam oldu..Çok teşekkür ederim..Eline sağlık...Kolay gelsin..
 
K L M hücrelerine aktarılan klasör,dosya ve sayfa isimlerini yazıyor T1 U1 hücrelerinide yardımcı olarak kullandım burada dosyanın içindeki sayfa adı değişsede veri alıyor ince nokta dosyada birden fazla sayfa varsa size uyurı verecek ve sayfa seçimini isteyecek.
 

Ekli dosyalar

Bu daha harika olmuş ..Çok güzel ..Sayfa adları dediğiniz gibi değiştirmiş olarak gelenler vardır..
Çok teşekkürler..


Range("C4:R38").ClearContents olarak kalmış ve üzerine fazla topluyordu

Range("C4:R55").ClearContents olarak düzelttim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst