Klasör içindeki excel dosyalarını açmadan makro çalıştırıp değişiklik yapmak

[hrryet]

Arkadaşlar merhaba.

Benim çok acil yardıma ihtiyacım var.

Şöyleki bilgisayarımda "listeler" isimli bir klasörüm var. bu klasör içinde 2000'e yakın excel dosyası var (her bir excel dosyasının adı farklı).

benim elimde bul-değiştir şeklinde bir makro var. mesela ayşe olanları bul ali yap gibi. fakat ben bunu tüm excel dosyalarını tek tek açarak çalıştırabiliyorum. bu benim çok fazla vaktimi alıyor.

bu excel dosyalarının içini açmadan, direkt klasör içinde makromu bir kerede çalıştırıp tüm excellerdeki kolon başlıklarını bir kerede aynı şekilde düzenlemek istiyorum. böyle bir şey mümkün mü acaba? bilgi verebilirseniz, yardımcı olabilirseniz çok sevinirim.
bu konuda yardımcı olabilecek arkadaşlara şimdiden çok çok teşekkür ediyorum.

herkese iyi çalışmalar.

 

[Orion1]

Arkadaşlar merhaba.

Benim çok acil yardıma ihtiyacım var.

Şöyleki bilgisayarımda "listeler" isimli bir klasörüm var. bu klasör içinde 2000'e yakın excel dosyası var (her bir excel dosyasının adı farklı).

benim elimde bul-değiştir şeklinde bir makro var. mesela ayşe olanları bul ali yap gibi. fakat ben bunu tüm excel dosyalarını tek tek açarak çalıştırabiliyorum. bu benim çok fazla vaktimi alıyor.

bu excel dosyalarının içini açmadan, direkt klasör içinde makromu bir kerede çalıştırıp tüm excellerdeki kolon başlıklarını bir kerede aynı şekilde düzenlemek istiyorum. böyle bir şey mümkün mü acaba? bilgi verebilirseniz, yardımcı olabilirseniz çok sevinirim.
bu konuda yardımcı olabilecek arkadaşlara şimdiden çok çok teşekkür ediyorum.

herkese iyi çalışmalar.

Mümkün.
Sayfa adları hepsinde aynimi.
Verinin aranıp değiştirilieceiği sütun hangisi.
Hangi veri değiştirelecek.
Dosyanaıaı ve değiştirilecek dosyalaradan bir kaç tane örnek ekleyip yollarsanız yardımcı oluruz.Not dosyaları 2003 formatında yüklerseniz iyi olur.2007 herkeste yok çünkü.Bendede.

 

[hrryet]

Sayfa adları hepsinde aynı değil maalesef. dosyalar ay isimleriyle ay-yıl olarak kayıtlı. mesela aralık_2009 şeklinde.

aşağıda eklediğim dosyalarda "ALBÜM"




ilginize çok teşekkür ederim.

 

[hrryet]

Sayfa adları hepsinde aynı değil maalesef. dosyalar ay isimleriyle ay_yıl olarak kayıtlı. mesela aralık_2009 şeklinde.

aşağıda eklediğim dosyalarda "ALBÜM" yazan kolon başlığını "album", " İCRACI" yazan kolon başlığını "yorumcuAd" , "ESER" yazan kolon başlığını da "eserAd", "KONTÖR YÜKLEME/DOWNLOAD" yazan kolon başlığını da "calmaSayisi" olarak düzeltmek istiyorum.

Birde dosyalarda yıl ve ay kolonları da hiç yok. ben yukarıda yapmak istediğime ek olarak bu 2 kolonu da açıp içerisine dosyanın adındaki yılı ve ayı ya yazmak istiyorum.

Detayları dosya içine tekrar yazdım.

İlginize çok teşekkür ederim. Kolay gelsin.

 

[Orion1]

Sanırım sayfa adları dosya adı ile ayni.
Peki değiştirilecek verinin ismi nerden alınacak.Hangi sütunda olacak bu isim.
Ve bulunanların nereleri nasıl diğiştirilecek?
Diğer konu ,Sütun başlıklarının değişmesi ve sayfa adının sütun başlığı olarak 2 ilave olması haledikldi.
Diğer dosyalarla ayni klasörde olması lazım.1 kere kulanmanız yetrlidir.
Dosya lar ektedir.Tüm klasör içinde bulunan tüm dosyalarda işlemi yapar.
Bu dosyaya bakın dönüş yapın sonra diğerleri için devam edicez.

Sub kolon_basliklrini_degisitr_ekle_59()
Dim sh As Worksheet, fso As Object, fs As Object, ad As String
Dim tar, sut As Byte, j As Byte, sat As Long
If MsgBox("Sayfa'daki sütun adlarını değiştirmek ve 2" _
 & "tane yeni ad eklemek istiyormusunuz", vbYesNo, "SÜTUN ADLARI DEĞİŞTİR") = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fs In fso.getfolder(ThisWorkbook.Path).Files
    If LCase(Left(fso.getextensionname(fs), 3)) = "xls" Then
        If fs.Name <> ThisWorkbook.Name Then
            Application.DisplayAlerts = False
            If Workbooks.Open(ThisWorkbook.Path & "\" & fs.Name).ReadOnly = True Then
                Workbooks(fs.Name).Close False
            End If
            Application.DisplayAlerts = True
            Range("A1").Value = "album"
            Range("B1").Value = "yorumcuAd"
            Range("C1").Value = "eserAd"
            Range("G1").Value = "calmaSayisi"
            Range("J1").Value = "yil"
            Range("K1").Value = "ay"
            ad = Left(fs.Name, Len(fs.Name) - 4)
            tar = Split(ad, "_")
            sut = 10
            sat = Cells(65536, "A").End(xlUp).Row
            If sat > 1 Then
                For j = LBound(tar) To UBound(tar)
                    Range(Cells(2, sut), Cells(sat, sut)).Value = tar(j)
                    sut = sut + 1
                Next
            End If
            ActiveWorkbook.Close True
        End If
    End If
Next fs
ThisWorkbook.Activate
Application.ScreenUpdating = True
Set fso = Nothing
MsgBox "Sütun adları değişti." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[hrryet]

Sanırım sayfa adları dosya adı ile ayni.
Peki değiştirilecek verinin ismi nerden alınacak.Hangi sütunda olacak bu isim.
Ve bulunanların nereleri nasıl diğiştirilecek?
Diğer konu ,Sütun başlıklarının değişmesi ve sayfa adının sütun başlığı olarak 2 ilave olması haledikldi.
Diğer dosyalarla ayni klasörde olması lazım.1 kere kulanmanız yetrlidir.
Dosya lar ektedir.Tüm klasör içinde bulunan tüm dosyalarda işlemi yapar.
Bu dosyaya bakın dönüş yapın sonra diğerleri için devam edicez.

Sub kolon_basliklrini_degisitr_ekle_59()
Dim sh As Worksheet, fso As Object, fs As Object, ad As String
Dim tar, sut As Byte, j As Byte
If MsgBox("Sayfa'daki sütun adlarını değiştirmek ve 2" _
 & "tane yeni ad eklemek istiyormusunuz", vbYesNo, "SÜTUN ADLARI DEĞİŞTİR") = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fs In fso.getfolder(ThisWorkbook.Path).Files
    If fso.getextensionname(fs) = "xls" Then
        If fs.Name <> ThisWorkbook.Name Then
            Application.DisplayAlerts = False
            If Workbooks.Open(ThisWorkbook.Path & "\" & fs.Name).ReadOnly = True Then
                Workbooks(fs.Name).Close False
            End If
            Application.DisplayAlerts = True
            Range("A1").Value = "album"
            Range("B1").Value = "yorumcuAd"
            Range("C1").Value = "eserAd"
            Range("G1").Value = "calmaSayisi"
            Range("J1").Value = "yil"
            Range("K1").Value = "ay"
            ad = Left(fs.Name, Len(fs.Name) - 4)
            tar = Split(ad, "_")
            sut = 10
            For j = LBound(tar) To UBound(tar)
                Cells(2, sut).Value = tar(j)
                sut = sut + 1
            Next
            If IsNumeric(Range("K2").Value) Then _
            Range("K2").Value = Range("K2").Value * 1
            ActiveWorkbook.Close True
        End If
    End If
Next fs
ThisWorkbook.Activate
Application.ScreenUpdating = True
Set fso = Nothing
MsgBox "Sütun adları değişti." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

sayfa adları klasör adı ile aynı değil. zaten tüm excelleri tek klasörde topladım. bir kerede bu kalsördeki tüm excellerde değişiklik yapmak istiyorum. klasör adı farkedermi bilemiyorum. "listeler" diyebiliriz mesela.

fakat yazdığınız kodu çalıştırdım ama 2 tane sheet var ve ne yaptığını anlamadım.

yinede çok teşekkür ederim ama çok karışık geldi. diğer dosyaların olduğu klasöre kaydettim kodunuzu ve çalıştırdım. hiç bişey olmadı. rica etsem benim gönderdiğim dosyalar üzerinde yapabilirmisiniz ki ben çalışıp çalışmadığını anlayabileyim. çünkü makroyu çalıştırınca bişey olmuyo. kendi dosyaslarımıda açınca hiç değişiklik yok maalesef.

 

[Orion1]

sayfa adları klasör adı ile aynı değil. zaten tüm excelleri tek klasörde topladım.

fakat yazdığınız kodu çalıştırdım ama 2 tane sheet var ve ne yaptığını anlamadım.

yinede çok teşekkür ederim ama çok karışık geldi. diğer dosyaların olduğu klasöre kaydettim kodunuzu ve çalıştırdım. hiç bişey olmadı. rica etsem benim gönderdiğim dosyalar üzerinde yapabilirmisiniz ki ben çalışıp çalışmadığını anlayabileyim. çünkü makroyu çalıştırınca bişey olmuyo. kendi dosyaslarımıda açınca hiç değişiklik yok maalesef.

Ben sayfa adları ile klasör adları aynimi diye sormadım ki zaten.Tespitim sayfa adları ile dosya adları aynimi diye sormuştum.
Sorumu iyi okursanız anlarsınız.
Diğer durum için ise
yolladığım dosyayı kullanacağığnın klasör içine kopyalayınız.
Oradaki butona basınız.Sizin kod ile bir işiniz yok.
Sadece ilk sayfdaki Butona basınız.O işlemi yapacak.Ne yapacak.
Söylemiş olduğunuz sütun adların değiştircek ayrıvca j vbve ksütunlarına ad ekleyecek ve j2 ve k2 hücresine dosyanın adını parçalayıp yazacak.
Dikkat ettiyseniz size yoladığım dosyada bu işlemleri yapmış durumd zaten.
Bu yolladığım dosya sadece bu işlemi yapıyor.
Diğer değişteirme konusu bundan ayrı.Onda daha öncede sordum bilinmezler var.Onları açığıa çıkarınca onuda yapıcam.
Bu dosyaı ve onu 2 ayrı yerde yapmamın sebebpi diğer dosyada her aram ve dğieşitirme yaprtıpğınızda bu sütun adlarınuı yazılmasına gerek yok.Bu işlemi zaten 1 kere yapacaksınız.Veya lazım oldukça yapacaksınız.Onun için 2 ayrı işlem olarak düşündüm ve 2 dosya yapıcam.Bu yolldaığım sadece sütun adların ı değiştiriyor.

 

[Orion1]

Yanlış dosya eklemişim
şimdi doğrusunu yükledim.Ayni yerden indirebilirisiniz.

 

[hrryet]

Kusura bakmayın oruç.. sizin sayfa dediğiniz şey shett'ler doğru ya. birden öyle düşünemedim. Peki bir de söylediğiniz şekilde deniyorum. durumu size bildireceğim.

teşekkür ederim.

 

[halit3]

alternatif kod:
alt klasör dahil

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim Sayfa_Adı As String
Private Sub CommandButton1_Click()
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
Set wb = Workbooks.Open(Kaynak & "\" & Dosya)
Application.DisplayAlerts = False
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
For r = 1 To ActiveWorkbook.Sheets.Count
sayfaadi = Workbooks(dosya_adı).Sheets(r).Name
Worksheets(sayfaadi).Cells(1, 1).Value = "album"
Worksheets(sayfaadi).Cells(1, 2).Value = "yorumcuAd"
Worksheets(sayfaadi).Cells(1, 3).Value = "eserAd"
Worksheets(sayfaadi).Cells(1, 7).Value = "calmaSayisi"
Worksheets(sayfaadi).Cells(1, 10).Value = "yıl"
Worksheets(sayfaadi).Cells(1, 11).Value = "ay"
On Error Resume Next
deg1 = Sheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To Val(deg1)
Worksheets(sayfaadi).Cells(i, 10).Value = Format(sayfaadi, "yyyy")
Worksheets(sayfaadi).Cells(i, 11).Value = Format(sayfaadi, "mmmm")
Next i
Next
Application.DisplayAlerts = True
wb.Save
wb.Close False
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

 

[hrryet]

Yanlış dosya eklemişim
şimdi doğrusunu yükledim.Ayni yerden indirebilirisiniz.

Evren Bey diğer makro bana ait olmadığı için olmamış . Şimdi oldu Bu kod işimi görecek. tekrar teşekkür ederim.

Fakat hani ay ve yıl kolonunu ekliyoruz ya, onun da içini dolduruyor. onu veri bulunan en son satıra kadar doldurması mümkün olabilir mi? bunu da yapabilir miyiz?

 

[Orion1]

Evren Bey diğer makro bana ait olmadığı için olmamış . Şimdi oldu Bu kod işimi görecek. tekrar teşekkür ederim.

Fakat hani ay ve yıl kolonunu ekliyoruz ya, onun da içini dolduruyor. onu veri bulunan en son satıra kadar doldurması mümkün olabilir mi? bunu da yapabilir miyiz?

5 numaralı mesajda dosyayı ekledim.İstediğiniz düzenlemyi yaptım.

 

[hrryet]

Yanlış dosya eklemişim
şimdi doğrusunu yükledim.Ayni yerden indirebilirisiniz.

teşekkür ederim. şimdi ki makronuz işime yaradı. istediğim şeyi yapıyor. diğer eklediğinizde bir karışıklık olmuş o nedenle anlayamadım kusura bakmayın.

fakat hani ay ve yıl ekliyor ya, veri olan en son satıra kadar doldurması mümkün olabilir mi?

örneğin aralık dosyası 857 satırda bitiyor. ay ve yıl kolonunu da o satıra kadar doldurabilir miyiz?

 

[Orion1]

teşekkür ederim. şimdi ki makronuz işime yaradı. istediğim şeyi yapıyor. diğer eklediğinizde bir karışıklık olmuş o nedenle anlayamadım kusura bakmayın.

fakat hani ay ve yıl ekliyor ya, veri olan en son satıra kadar doldurması mümkün olabilir mi?

örneğin aralık dosyası 857 satırda bitiyor. ay ve yıl kolonunu da o satıra kadar doldurabilir miyiz?

Zaten öyle yaptım.Yolladığım dosyayı inceledinizmi?

 

[hrryet]

kusura bakmayın ben gönderdiğim cevabı göremeyince aynısını bidaha gönderdim.

evet aldım yeni kodunuzu şu an işimi görüyor istediğim gibi olmuş. emeğinize, bilginize sağlık.

peki bunu bir klasörde 20002e yakın tüm dosyalarda çalıştırabilir miyim yoksa daha az şekilde mi çalıştır malıyım? 50-100 dosya gibi..

 

[Orion1]

kusura bakmayın ben gönderdiğim cevabı göremeyince aynısını bidaha gönderdim.

evet aldım yeni kodunuzu şu an işimi görüyor istediğim gibi olmuş. emeğinize, bilginize sağlık.

peki bunu bir klasörde 20002e yakın tüm dosyalarda çalıştırabilir miyim yoksa daha az şekilde mi çalıştır malıyım? 50-100 dosya gibi..

Çalıştırabilirsiniz.
Bunu o klasörde deneyin şimdi.
Sonra 2nci soruyu halledelim.:
Denedikten sonra bana dönerseniz iyi olur.Sonuç ne oldu.ne kadar sürede itti gibi.

 

[hrryet]

alternatif kod:
alt klasör dahil

Sizede çok teşekkür ederim. yazdığınız kod istediğim gibi işimi görüyor. sizden de buna ek olarak şunu rica edebilir miyim. ay ve yıl kolonunu veri bulunan son satıra kadar doldursun. bu da olabilirse kodunuz tam olarak işime yarayacak.

şöyleki mesela aralık dosyası 857 satır ay ve yıl kolonunu o satıra kadar doldursun.

ne olur ne olmaz elimde yedek bir kodun olmasının faydalı olacağını düşünüyorum. çünkü benim işim iiçin bu sistem gerekli ve dosyalarım hergün artıyor.

tekrar teşekkür ederim iyi çalışmalar.

 

[hrryet]

Çalıştırabilirsiniz.
Bunu o klasörde deneyin şimdi.
Sonra 2nci soruyu halledelim.:
Denedikten sonra bana dönerseniz iyi olur.Sonuç ne oldu.ne kadar sürede itti gibi.

denedim ve oldu. tüm dosyalarda en alt satıra kadar ayı ve yılı da ekliyor. başlıkları da ekliyor.3 dosya için 1 dk sürmüyor.

size bir sorum daha olacak ben bu kodu farklı formattaki listelerimdeki başlıkları değiştirmek için de kullanabilir miyim? kodda gerekli kolon başlığı değişikliklerini yaparak?

 

[Orion1]

denedim ve oldu. tüm dosyalarda en alt satıra kadar ayı ve yılı da ekliyor. başlıkları da ekliyor.3 dosya için 1 dk sürmüyor.

size bir sorum daha olacak ben bu kodu farklı formattaki listelerimdeki başlıkları değiştirmek için de kullanabilir miyim? kodda gerekli kolon başlığı değişikliklerini yaparak?

Ben gerçek yerinde tüm dosyalar için çalıştırıp sonucu iletin anlamında demiştim.Bakalım 2000 dosyada ne performans verecek.Problem varmı gibisinden.
Önemli : bu kodlar hedef dosyalarda aktif sayfaya verilerin yazıldığı şekilde tasarlamıştır.
1 den fazla sayfası olan dosyalarda hangi sayfa aktif ise o sayfaya veriler yazılır.

 

[hrryet]

Ben gerçek yerinde tüm dosyalar için çalıştırıp sonucu iletin anlamında demiştim.Bakalım 2000 dosyada ne performans verecek.Problem varmı gibisinden.
Önemli : bu kodlar hedef dosyalarda aktif sayfaya verilerin yazıldığı şekilde tasarlamıştır.
1 den fazla sayfası olan dosyalarda hangi sayfa aktif ise o sayfaya veriler yazılır.

gerçek yerinde çalıştırdım zaten bu dosyalar gerçek olanlar. fakat tamamaında çalıştırmadım çünkü birkaç düzenleme yapmam gerekiyor. mesela 2000 dosyayı tek kalasöre almak gibi. her biri ay ay ayrı ayrı yerlerde. bu da bir kaç günümü alacak maalesef.

ama şu hali gayet yeterli. sonuçta yapacağım şey bu.çok çok teşekür ederim.
takıldığım yer olursa sizden yine bilgi almaktan memnun olurum. iyi çalışmalar,başarılar.