• DİKKAT

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

klasörlerdeki sanıklar adlı sayfaları birleştirme

T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,181
Excel Vers. ve Dili
Ofis 2019 Türkçe
Ceraim adlı kalasör içerisinde C_No_1 den başlayarak C_No_1070'e kadar isim içeren klasörler bulunmakta olup, bu klasörlerin hepsinde COCUK_PRO.XLS adlı çalışma kitabı mevcuttur.
Yapmak istediğim, COCUK_PRO.XLS çalışma kitaplarındaki Sayfa3(SANIKLAR) adlı sayfalarda sutunlar halinde bulunan bir veya birden fazla şüphelilere ait bilgiler bulunmaktadır, bu bilgileri yani B3:K76 hücre aralığını kopyalayarak, arşivdata.xls çalışma kitabına altalta satırlar halinde (ters yapıştır) arşiv oluşturmak istiyorum
 

Ekli dosyalar

evet uzman arkadaşlarım yorum bekliyorum, çözüm bekliyorum, alt klasörler ve aynı dosya ismi olunca zorlandım, sitemizde daha evvelce bu şekilde hiç bir soru ve çözüm olmadığını biliyorum.
 
bu dosyaya bir bakınız.
 

Ekli dosyalar

Halit hocam ilginiz için çok teşekkür ediyorum, orjinal dosyalarda deneyip size tekrar bilgi vereceğim.
 
Halit Hocam, yaklaşık 4000 (dört yıllık) klasörde yaptığım uygulamada 5000 kişiye ait sorgulamayı hiç bir sorun yaşamadan yaklaşık 25 dakika içerisinde almış bulunmaktadır, eliniz kolunuz dert görmesin, ilginiz için çok çok teşekkürler. Saygılar.
 
iyi çalışmalar
 
bu kodda dosyaları açmadan veriyi alıyor.

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String

Private Sub CommandButton1_Click()
a = MsgBox("Dosyalardan veri almak istiyormusunuz..?", vbYesNo, " Tablo")
If a = vbNo Then
Exit Sub
End If
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
sat = 2
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
Liste (Klasor.Items.Item.path)
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(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "SANIKLAR" & "'!R"
For r = 2 To 11
If ExecuteExcel4Macro(deg & 3 & "C" & r) <> "" Then
For i = 3 To 77
Cells(sat, i - 2) = ExecuteExcel4Macro(deg & i & "C" & r)
If Cells(sat, i - 2) = 0 Then
Cells(sat, i - 2) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1  'sat + 1
End If
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.path
Liste (f.path)
sonraki:
Next
Set fL = Nothing
End Sub
 
halit3' Alıntı:
bu kodda dosyaları açmadan veriyi alıyor.

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String

Private Sub CommandButton1_Click()
a = MsgBox("Dosyalardan veri almak istiyormusunuz..?", vbYesNo, " Tablo")
If a = vbNo Then
Exit Sub
End If
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
sat = 2
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
Liste (Klasor.Items.Item.path)
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(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "SANIKLAR" & "'!R"
For r = 2 To 11
If ExecuteExcel4Macro(deg & 3 & "C" & r) <> "" Then
For i = 3 To 77
Cells(sat, i - 2) = ExecuteExcel4Macro(deg & i & "C" & r)
If Cells(sat, i - 2) = 0 Then
Cells(sat, i - 2) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1  'sat + 1
End If
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.path
Liste (f.path)
sonraki:
Next
Set fL = Nothing
End Sub
[/QUOTE

Halit Bey,
1. Ters Yapıştırma işlemini düzlemek istediğimizde (birebir aynı) kod da nasıl bir değişiklik yapılması gerekir.
2. Yol sabit olunca Alınacak veriler Aynı klasörde farklı dosyalardan olursa ne gibi değişiklik yaoılmalıdır. ayrı bir konu açmadan cevap alabilirmiyiz?
ilgilerinize teşekkürler.
Genişletmek için tıkla ...
 
yukarıdaki kodla B3-K3 arası değerlerden boş değilse B3-B77, C3-C77 vb son olarakta K3-K77 değerleri yani yukarıdan aşağı olan verileri başka bir dosyada ikinci satırdan başlamak üzere yatay olarak veriler aktarılmaktadır.Ters yapıştırma işlemini düzeltmek için öncelikle hangi hücredeki veriyi nereye aktaracağınıza bağlı

buradaki püf nokta
Cells(sat, i - 2) = ExecuteExcel4Macro(deg & i & "C" & r)
Genişletmek için tıkla ...

sat,i,r değerleri

sat değeri yukarıdan aşağıya verileri yazmak
i değeri bir taraftan yukarıdan aşağı veriyi okumak diğer taraftan yatay olarak verileri yazmak
r değeri yukarıdan aşağı verileri okumak

tabi bu değerlerin başlangıç satır sutün değerlerini döngü ile belirlemek gerekir.

2. soruna gelince

yol sabit olsun fark etmez dosya isimleri fark etmez yukurıdaki örnek uygulamada her dosyanın içinde

deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "SANIKLAR" & "'!R"
Genişletmek için tıkla ...

SANIKLAR sayfasının mutlaka olması gerekiyor bu sayfa olmazsa veriler alınamaz.
 
Halit Bey,
Aynı klasörde Farklı isimlerdeki 4 adet dosyanın içinde aynı isimdeki sayfalardan A2:AN570 aralığındaki bilgileri seçili sayfada A2 den başlamak üzere alt alta yazdırma işlemi için gereken kod işimi şimdilik görecektir. İlgi ve alaka için Tekrar teşekkür ederim. Daha önceki çalışmalarınızı da inceledim kod yazma işinden anlamayınca olmuyor bir türlü çok zaman kaybediliyor.
 
bunu denermisiniz.
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String

Private Sub CommandButton1_Click()

a = MsgBox("Dosyalardan veri almak istiyormusunuz..?", vbYesNo, " Tablo")
If a = vbNo Then
Exit Sub
End If
sat = 2 'Cells(Columns.Count,"A").End(3).Row + 1
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
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
Liste (Klasor.Items.Item.path)
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(Yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & "SANIKLAR" & "'!R"
For r = 2 To 570
For i = 1 To 40
Cells(sat, i) = ExecuteExcel4Macro(deg & r & "C" & i)
If Cells(sat, i) = 0 Then
Cells(sat, i) = ""
End If
Next i
sat = Cells(Rows.Count, "A").End(3).Row + 1 'sat + 1
Next r
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.path
Liste (f.path)
sonraki:
Next
Set fL = Nothing
End Sub
Genişletmek için tıkla ...
 
Halit Bey,
Aşağıdaki satırda hata verdi iptal ettim çalıştı. Çok Teşekkür ederim.
Allah ilminizi artırsın her şey gönlünüzce olsun.
'Set fL = CreateObject("Scripting.FileSystemObject").getfold er(Yol).SubFolders
 
hayır iptal etmeyin (getfold er) bunun arasındaki boşluğu kaldırın sorun düzelecektir
getfolder
 
Mesaj 1 de sorduğum soruma ilave olarak

Mesaj1 de sorduğum sorumun cevabını Sn. Halit hocam vermişti, şimdi bu soruma ilave olarak aynı çalışma kitabının Bilgiler sayfasındaki B2,B3,B4,B5, ve B7 hücrelerindeki bilgilerinde Sanıklar sayfasından alınan bilgilerin başına ilave etmek istiyorum, örneğin Sanıklar sayfasında beş kişinin bilgisi varsa bu beş kişinin bilgilerinin başına (A,B,C,D,E) sutunlarına Bilgiler sayfasındaki B2,B3,B4,B5 ve B7 hücresindeki bilgilerin gelmesini nasıl sağlayabilirim. Arşiv datamızda bi kişilerin hangi tarihte hangi karakoldan ve hangi suçtan geldiklerinin de ilave edilmesi için. Yardımlarınız için şimdiden teşekkür ediyorum.
 

Ekli dosyalar

tahsinanarat' Alıntı:
Mesaj1 de sorduğum sorumun cevabını Sn. Halit hocam vermişti, şimdi bu soruma ilave olarak aynı çalışma kitabının Bilgiler sayfasındaki B2,B3,B4,B5, ve B7 hücrelerindeki bilgilerinde Sanıklar sayfasından alınan bilgilerin başına ilave etmek istiyorum, örneğin Sanıklar sayfasında beş kişinin bilgisi varsa bu beş kişinin bilgilerinin başına (A,B,C,D,E) sutunlarına Bilgiler sayfasındaki B2,B3,B4,B5 ve B7 hücresindeki bilgilerin gelmesini nasıl sağlayabilirim. Arşiv datamızda bi kişilerin hangi tarihte hangi karakoldan ve hangi suçtan geldiklerinin de ilave edilmesi için. Yardımlarınız için şimdiden teşekkür ediyorum.
Genişletmek için tıkla ...

Ekli dosyaya bir bakınız anladığım kadarı ile yapmaya çalıştım.
 

Ekli dosyalar

Sn. Halit3 Hocam, gerçekten harikasınız, gece uykum kaçtı saat 03.00 sıralarında konuya göz attığımda cevabınızı görmek beni çok sevinirdi, çok teşekkür ediyorum, elinize sağlık.
 
tahsinanarat' Alıntı:
Sn. Halit3 Hocam, gerçekten harikasınız, gece uykum kaçtı saat 03.00 sıralarında konuya göz attığımda cevabınızı görmek beni çok sevinirdi, çok teşekkür ediyorum, elinize sağlık.
Genişletmek için tıkla ...

iyi çalışmalar
 
Sn. halit hocam mesaj 15 de sorduğum soruya ilaveten, SANIKLAR, Bilgiler sayfasından verileri alma işlemine cevap vermiştiniz, ilave olarak aynı çalışma kitabının MAĞDUR_MUSTEKİLER sayfasından da SANIKLAR sayfasından aldığımız bilgiler gibi Magdurları da almak istiyorum, koda nasıl bir ilave yapmalıyız. Cevabınız için şimdiden teşekkür eder hayırlı Ramazanlar dilerim.
 
tahsinanarat' Alıntı:
Sn. halit hocam mesaj 15 de sorduğum soruya ilaveten, SANIKLAR, Bilgiler sayfasından verileri alma işlemine cevap vermiştiniz, ilave olarak aynı çalışma kitabının MAĞDUR_MUSTEKİLER sayfasından da SANIKLAR sayfasından aldığımız bilgiler gibi Magdurları da almak istiyorum, koda nasıl bir ilave yapmalıyız. Cevabınız için şimdiden teşekkür eder hayırlı Ramazanlar dilerim.
Genişletmek için tıkla ...


Sayfanın kod bölümüne bunu yapıştırın

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim sat As String
Private Sub CommandButton1_Click()
a = MsgBox("Dosyalardan veri almak istiyormusunuz..?", vbYesNo, " Tablo")
If a = vbNo Then
Exit Sub
End If
Sheets("Sanıklar").Range(Sheets("Sanıklar").Cells(2, 1), Sheets("Sanıklar").Cells(Rows.Count, Columns.Count)).Value = ""
Sheets("Mağdurlar").Range(Sheets("Mağdurlar").Cells(2, 1), Sheets("Mağdurlar").Cells(Rows.Count, Columns.Count)).Value = ""
sat = 2
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
Liste (Klasor.Items.Item.Path)
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(Yol As String)
Dim sayfa(2)
Dim sayfa1(2)
sayfa(1) = "SANIKLAR": sayfa(2) = "MAGDUR_MUSTEKİLER"
sayfa1(1) = "Sanıklar": sayfa1(2) = "Mağdurlar"

Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Yol).SubFolders
Dim wb As Workbook
Dosya = Dir(Yol & "\*.*")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
tmp = Dosya
For j = 1 To 2
sat = Sheets(sayfa1(j)).Cells(Rows.Count, "f").End(3).Row + 1  'sat + 1
deg = "'" & Kaynak & "\" & "[" & tmp & "]" & sayfa(j) & "'!R"
For r = 2 To 11
If ExecuteExcel4Macro(deg & 3 & "C" & r) <> "" Then
Sheets(sayfa1(j)).Cells(sat, 1) = ExecuteExcel4Macro(deg & "2C2")
Sheets(sayfa1(j)).Cells(sat, 2) = ExecuteExcel4Macro(deg & "3C2")
Sheets(sayfa1(j)).Cells(sat, 3) = ExecuteExcel4Macro(deg & "4C2")
Sheets(sayfa1(j)).Cells(sat, 4) = ExecuteExcel4Macro(deg & "5C2")
Sheets(sayfa1(j)).Cells(sat, 5) = ExecuteExcel4Macro(deg & "7C2")
For i = 3 To 77
Sheets(sayfa1(j)).Cells(sat, i + 3) = ExecuteExcel4Macro(deg & i & "C" & r)
If Sheets(sayfa1(j)).Cells(sat, i + 3) = 0 Then
Sheets(sayfa1(j)).Cells(sat, i + 3) = ""
End If
Next i
Sheets(sayfa1(j)).Cells(sat, 1) = sayfa(j)
sat = Sheets(sayfa1(j)).Cells(Rows.Count, "f").End(3).Row + 1  'sat + 1
End If
Next r
Next j

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst