Klasör içindeki Dosyalarla İşlem

Excel ile herhangi bir klasor icerisindeki dosyalarla işlem uzerine;

Bu haftasonu site uzerindeki dosyalara sitemizin anasayfasinin ve iletisim linklerinin konulmasi konusunda bir fikre aklim yatti. Once bir kac dosyayi acip bu linkleri yapistirdiktan sonra sizlerle cok fazla dosya ve konu paylasimi icerisinde bulundugumu gordum ve farkli bir yol izlemeye karar verdim.

Fikrin ozu suyduki site uzerindeki tum dosyalari indirecektim ve bir klasor icerisine alacaktim, daha sonra ise bu klasor icerisinde bir for each dongusu yaratarak tum dosyalari acip bu dosyalara sitemizin linkleri bulunan shape nesneleri ekleyecektim.

2013 versiyon excelde bu islemin hic kasmadigini ayrica bildirmek isterim, diger versiyonlar ile yeniden deneme firsatim olmadi.

Bu islem icin ornek dosyayi paylasmadan once kodlari paylasacagim fakat cok fazla anlatima girmeme gerek yok cunku daha onceki konularda ogrendiklerimiz ve kodlar uzerine aldigim notlar ile anlasilabilir duruma geldigini dusunuyorum.

Sub Klasordeki_Dosya_listesi()

Dim fd As FileDialog
Dim Secilen_Dosyanin_Yolu As String
Dim Secilen_Klasor
Dim Secilen_Klasor_Temp
Dim Secili_Yol As FileDialog
Dim fs
Dim Extra_Slash
Extra_Slash = ""
Dim Dosyam

'Secilen dosya yolunun alinmasi
Set Secili_Yol = Application.FileDialog(msoFileDialogFolderPicker)
With Secili_Yol
'Kalici bir pencere acma
.AllowMultiSelect = False
If .Show Then
   'Kullanici bir klasor secer...

   'Klasorun icerisinde bir dongu olusturulur
   For Each Secilen_Klasor In .SelectedItems

       'Secilen klasorun yoluna extradan bir slash ekleme
       Secilen_Dosyanin_Yolu = Secilen_Klasor & Extra_Slash

       Set fs = CreateObject("Scripting.FileSystemObject")
       Set Secilen_Klasor_Temp = fs.GetFolder(Secilen_Dosyanin_Yolu)

           'Klasordeki dosyalar icin dongu
           For Each Dosyam In Secilen_Klasor_Temp.Files
               'MsgBox Dosyam.Name
               'Dosyalarin isimlerini mesaj gostermek icin ornek
               'Workbooks.Open Filename:=Dosyam
               'Ayni sekilde dosyalarinizi acmak icin bir ornek

               'ActiveWorkbook.Save
               'Dosyayi kaydet
               'ActiveWorkbook.Close
               'Dosyayi Kapat
           Next
   Next
End If
End With

End Sub

Ne kadar kodlar uzerine not almis olsamda uzun sayilacak bir kod dizisi o yuzden anlamadiginiz bolumleri lutfen sorunuz, mesajla dosyanin adini yazdirma, kapali dosyayi acmak, kaydetmek, kapatmak gibi ornekleri kapatmak kaydi ile kodlara ekledim, bunlari acarak test edebilirsiniz.

Klasör içindeki Dosyalarla İşlem

Pivot Tablo Silme

Makroyla Pivot Tablo Silme

Makroyla calismalarinizdaki tum pivot tablolari silebilmek icin asagidaki kodlari kullanabilirsiniz, gerekli aciklamalari kodlar icerisine yazdim, Tum sayfalarda silme islemi icin For Each kullaniyoruz klasik 🙂

Daha sonra kodlarda da goreceginiz uzere silme islemini gerceklestiriyoruz, inceleyiniz, iyi calisalar.

Sub Ozet_Tablo_Sil()

    Dim Pt As PivotTable
    Dim Ws As Worksheet

'Tum Sayfalarda Islem
    For Each Ws In ActiveWorkbook.Worksheets
    Worksheets(Ws.Name).Select

'Ozet Tablolarda Islem
    For Each Pt In Ws.PivotTables

'Ozet Tablolari Silme
    Pt.PivotSelect "", xlDataAndLabel, True
    Selection.Delete Shift:=xlToLeft

        Next Pt
    Next Ws
End Sub

Pivot Tablo Silme

Commentlerin Ismini Degistirme

 

Yukaridaki resimde gordugunuz gibi bir commentimiz var ve comment ismimiz MUSTAFA ASLAN olarak gorunuyor ve bunu degistirmek icin yaptigimiz bir uygulama var. Ornegimizde Muhammet Mustafa ASLAN olarak degistirmek istiyoruz.. 

Resimdeki gibi bir pencereden yeni ismi seciyoriz ve replace etmeseini sagliyoruz.. 

 

 

Kullanici Adini degistirmek istersek burada evet`i secmemiz yeterli olacak..
Yukarida gordugunuz gibi gerekli degistirme islemi yapilmis olarak veriliyor..

Sub Comment_Adini_Degistir()

Dim Calisma_Sayfasi As Worksheet

Dim yrm As Comment

Dim yrm2 As Comment

Dim Eski_Metin As String

Dim Yeni_Metin As String

Dim Kullanici As String

Dim Yrm_Metni As String

Dim Mesaj_Metni As String

Dim Break As Long

Dim vKullanici As Boolean

On Error GoTo errHandler

Kullanici = Application.UserName

Eski_Metin = InputBox("Eski Metin", "Degisecek Ismi Giriniz", Kullanici)

If Len(Eski_Metin) = 0 Then

Mesaj_Metni = "Comment Ismi Degistirilemedi" _

& vbCrLf _

& "Eski isim en az bir karakter olmali"

GoTo exitHandler

End If

Yeni_Metin = InputBox("Yeni isim (Minumum Bir Karakter)", "Yeni Ismi Giriniz", Kullanici)

If Len(Yeni_Metin) = 0 Then

Mesaj_Metni = "Comment Ismi Degistirilemedi" _

& vbCrLf _

& "Yeni isim en az bir karakter olmali"

GoTo exitHandler

End If

Application.UserName = Yeni_Metin

Mesaj_Metni = "Comment Ismi Degistirilemedi"

For Each Calisma_Sayfasi In ActiveWorkbook.Worksheets

For Each yrm In Calisma_Sayfasi.Comments

Yrm_Metni = Replace(yrm.Text, Eski_Metin, Yeni_Metin)

yrm.Delete

Set yrm2 = yrm.Parent.AddComment

yrm2.Text Text:=Yrm_Metni

Break = InStr(1, yrm2.Text, Chr(10))

If Break > 0 Then

With yrm2.Shape.TextFrame

.Characters.Font.Bold = False

.Characters(1, Break - 1).Font.Bold = True

End With

End If

Next yrm

Next Calisma_Sayfasi

vKullanici = MsgBox("Yeni Ad Kullanici Adi olarak Saklansin mi?", vbYesNo + vbQuestion, "Excel Kullanici Ismi")

If vKullanici <> vbYes Then

Application.UserName = Kullanici

End If

Mesaj_Metni = "Tamamlandi!"

exitHandler:

MsgBox Mesaj_Metni

Exit Sub

errHandler:

Resume exitHandler

End Sub

bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Comment Ismini Degistir

Commentlerinize Resim Ekleyin

 

Resmimizde gordugunuz gibi commentlerinize resim eklemenizde mumkun, tabiki bu islem visual basic sayesinde oluyor. oncelikle kodlari vereyim;

Sub add_yrm()

Dim List_Araligi As Range

Dim c As Range

Dim yrm As Comment

Dim Resim_Yeri As String

On Error Resume Next

'dosya icerisindeki dosya isimleri yazan alani tanimlama

Set List_Araligi = Range("A1:A4")

'Resmin bulundugu klasorun dosya yolu

Resim_Yeri = "C:Data"

If Right(Resim_Yeri, 1) <> "" Then

Resim_Yeri = Resim_Yeri & ""

End If

For Each c In List_Araligi

With c.Offset(0, 1)

Set yrm = .Comment

If yrm Is Nothing Then

Set yrm = .AddComment

End If

With yrm

.Text Text:=""

.Shape.Fill.UserPicture Resim_Yeri & c.Value

.Visible = False

End With

End With

Next c

End Sub

Kodlarin uzerindede aktardim fakat onemli noktalara tekrar deginmek istiyorum, oncelikle dosya yolunuzu dogru yazmalisiniz; ornekte  C:Data olarak verilmisti. ayni sekilde bu dosya yolundaki dosyalarinizin isimlerinin bulundugu alani da kodla tanitmalisiniz kodlarda Set List_Araligi = Range(“A1:A4”) seklinde geciyordu..

Ekli dosyayi incelerseniz daha rahat anlasilir olacaktir..

bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Yorumda Resim

Yorumlara Numara Verme

Ornek resimde gordugunuz uzere yorumumuzun kosesinde bir sayi var bu yorumumuzun sayfadaki sayisini bildirmektedir..

Sub Yorum_Numarasi_verme()

Dim Sayfa As Worksheet

Dim yrm As Comment

Dim lyrm As Long

Dim Aralik_yrm As Range

Dim yrm_Sekil As Shape

Dim Sekil_Genisligi As Double 'shape width

Dim Sekil_Yuksekligi As Double 'shape height

Set Sayfa = ActiveSheet

Sekil_Genisligi = 8

Sekil_Yuksekligi = 6

lyrm = 1

For Each yrm In Sayfa.Comments

Set Aralik_yrm = yrm.Parent

With Aralik_yrm

Set yrm_Sekil = Sayfa.Shapes.AddShape(msoShapeRectangle, _

Aralik_yrm.Offset(0, 1).Left - Sekil_Genisligi, .Top, Sekil_Genisligi, Sekil_Yuksekligi)

End With

With yrm_Sekil

.Name = "yrmNum" & .Name

With .Fill

.ForeColor.SchemeColor = 9 'white

.Visible = msoTrue

.Solid

End With

With .Line

.Visible = msoTrue

.ForeColor.SchemeColor = 64 'automatic

.Weight = 0.25

End With

With .TextFrame

.Characters.Text = lyrm

.Characters.Font.Size = 5

.Characters.Font.ColorIndex = xlAutomatic

.MarginLeft = 0#

.MarginRight = 0#

.MarginTop = 0#

.MarginBottom = 0#

.HorizontalAlignment = xlCenter

End With

.Top = .Top + 0.001

End With

lyrm = lyrm + 1

Next yrm

End Sub

Daha sonra silmek istersek gerekecek kodlar;

Sub Yorum_Numarasini_Sil()

Dim Sayfa As Worksheet

Dim Sekil As Shape

Set Sayfa = ActiveSheet

For Each Sekil In Sayfa.Shapes

If Not Sekil.TopLeftCell.Comment Is Nothing Then

If Left(Sekil.Name, 6) = "YrmNum" Then

Sekil.Delete

End If

End If

Next Sekil

End Sub

bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Ciktida O Satirda Comment Oldugunu Gosterme

Ornek resimde gordugunuz uzere 2 tane kirmizi isaret var bunlarin kosede olani normalde otomatik olarak software`da gorebildiginiz orada comment oldugunu gosteren isarettir, digeri ise yazicidan cikti aldiginizda da gorunebilen bizim olusturdugumuz bir isarettir, yani yapmak istedigimiz her comment bulunan hucreye bir ucgen daha yapmak.. Bu ucgen icin kodlarda ayrica 3 ayri renk secenegide verecegiz;

Sub Comment_Ucgeni_Olusturma()

Dim sayfa As Worksheet

Dim yrm As Comment

Dim Aralik_yrm As Range

Dim Ucgenyrm As Shape

Dim Ucgen_Genisligi As Double

Dim Ucgen_Yuksekligi As Double

Set sayfa = ActiveSheet

Ucgen_Genisligi = 6

Ucgen_Yuksekligi = 4

For Each yrm In sayfa.Comments

Set Aralik_yrm = yrm.Parent

With Aralik_yrm

Set Ucgenyrm = sayfa.Shapes.AddShape(msoShapeRightTriangle, _

Aralik_yrm.Offset(0, 1).Left - Ucgen_Genisligi, .Top, Ucgen_Genisligi, Ucgen_Yuksekligi)

End With

With Ucgenyrm

.Flip msoFlipVertical

.Flip msoFlipHorizontal

.Fill.ForeColor.SchemeColor = 10 'Kirmizi

'12=Mavi, 57=Yesil

.Fill.Visible = msoTrue

.Fill.Solid

.Line.Visible = msoFalse

End With

Next yrm

End Sub

Daha sonra silmek istersek gerekecek kodlar;

Sub Comment_Ucgeni_Sil()

Dim sayfa As Worksheet

Dim Ucgen As Shape

Set sayfa = ActiveSheet

For Each Ucgen In sayfa.Shapes

If Not Ucgen.TopLeftCell.Comment Is Nothing Then

If Ucgen.AutoShapeType = _

msoShapeRightTriangle Then

Ucgen.Delete

End If

End If

Next Ucgen

End Sub

Bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Ciktida O Satirda Comment Oldugunu Gosterme

Ornek resimde gordugunuz uzere 2 tane kirmizi isaret var bunlarin kosede olani normalde otomatik olarak software`da gorebildiginiz orada comment oldugunu gosteren isarettir, digeri ise yazicidan cikti aldiginizda da gorunebilen bizim olusturdugumuz bir isarettir, yani yapmak istedigimiz her comment bulunan hucreye bir ucgen daha yapmak.. Bu ucgen icin kodlarda ayrica 3 ayri renk secenegide verecegiz;

Sub Comment_Ucgeni_Olusturma()

Dim sayfa As Worksheet

Dim yrm As Comment

Dim Aralik_yrm As Range

Dim Ucgenyrm As Shape

Dim Ucgen_Genisligi As Double

Dim Ucgen_Yuksekligi As Double

Set sayfa = ActiveSheet

Ucgen_Genisligi = 6

Ucgen_Yuksekligi = 4

For Each yrm In sayfa.Comments

Set Aralik_yrm = yrm.Parent

With Aralik_yrm

Set Ucgenyrm = sayfa.Shapes.AddShape(msoShapeRightTriangle, _

Aralik_yrm.Offset(0, 1).Left - Ucgen_Genisligi, .Top, Ucgen_Genisligi, Ucgen_Yuksekligi)

End With

With Ucgenyrm

.Flip msoFlipVertical

.Flip msoFlipHorizontal

.Fill.ForeColor.SchemeColor = 10 'Kirmizi

'12=Mavi, 57=Yesil

.Fill.Visible = msoTrue

.Fill.Solid

.Line.Visible = msoFalse

End With

Next yrm

End Sub

Daha sonra silmek istersek gerekecek kodlar;

Sub Comment_Ucgeni_Sil()

Dim sayfa As Worksheet

Dim Ucgen As Shape

Set sayfa = ActiveSheet

For Each Ucgen In sayfa.Shapes

If Not Ucgen.TopLeftCell.Comment Is Nothing Then

If Ucgen.AutoShapeType = _

msoShapeRightTriangle Then

Ucgen.Delete

End If

End If

Next Ucgen

End Sub

Bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Tum sayfalardaki Commentleri Bir Sayfada Listeleme

Asagidaki gibi bir yorumu alttaki gibi listeleyebilecek kodlar icin ornek;

Sub Tum_Yorumlari_Listele()

Application.ScreenUpdating = False

Dim yrmAraligi As Range

Dim Hucre As Range

Dim sayfa As Worksheet

Dim Yeni_Sayfa As Worksheet

Dim i As Long

Set Yeni_Sayfa = Worksheets.Add

Yeni_Sayfa.Range("A1:E1").Value = _

Array("Sayfa", "Adres", "Ad", "Deger", "Yorum")

For Each sayfa In ActiveWorkbook.Worksheets

On Error Resume Next

Set yrmAraligi = sayfa.Cells.SpecialCells(xlCellTypeComments)

On Error GoTo 0

If yrmAraligi Is Nothing Then

'Bisey Yapma

Else

i = Yeni_Sayfa.Cells(Rows.Count, 1).End(xlUp).Row

For Each Hucre In yrmAraligi

With Yeni_Sayfa

i = i + 1

On Error Resume Next

.Cells(i, 1).Value = sayfa.Name

.Cells(i, 2).Value = Hucre.Address

.Cells(i, 3).Value = Hucre.Name.Name

.Cells(i, 4).Value = Hucre.Value

.Cells(i, 5).Value = Hucre.Comment.Text

End With

Next Hucre

End If

Set yrmAraligi = Nothing

Next sayfa

Yeni_Sayfa.Cells.WrapText = False

Yeni_Sayfa.Columns("E:E").Replace What:=Chr(10), _

Replacement:=" ", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, _

SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

End Sub

Bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Tum sayfalardaki Commentleri Bir Sayfada Listeleme

Asagidaki gibi bir yorumu alttaki gibi listeleyebilecek kodlar icin ornek;

Sub Tum_Yorumlari_Listele()

Application.ScreenUpdating = False

Dim yrmAraligi As Range

Dim Hucre As Range

Dim sayfa As Worksheet

Dim Yeni_Sayfa As Worksheet

Dim i As Long

Set Yeni_Sayfa = Worksheets.Add

Yeni_Sayfa.Range("A1:E1").Value = _

Array("Sayfa", "Adres", "Ad", "Deger", "Yorum")

For Each sayfa In ActiveWorkbook.Worksheets

On Error Resume Next

Set yrmAraligi = sayfa.Cells.SpecialCells(xlCellTypeComments)

On Error GoTo 0

If yrmAraligi Is Nothing Then

'Bisey Yapma

Else

i = Yeni_Sayfa.Cells(Rows.Count, 1).End(xlUp).Row

For Each Hucre In yrmAraligi

With Yeni_Sayfa

i = i + 1

On Error Resume Next

.Cells(i, 1).Value = sayfa.Name

.Cells(i, 2).Value = Hucre.Address

.Cells(i, 3).Value = Hucre.Name.Name

.Cells(i, 4).Value = Hucre.Value

.Cells(i, 5).Value = Hucre.Comment.Text

End With

Next Hucre

End If

Set yrmAraligi = Nothing

Next sayfa

Yeni_Sayfa.Cells.WrapText = False

Yeni_Sayfa.Columns("E:E").Replace What:=Chr(10), _

Replacement:=" ", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, _

SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

End Sub

Bu konu comment – Yorum haftasi etkinligi dolayisiyla acilmistir..

Commentleri Yeni Bir Sayfada Listeleme



Usteki gibi bir yorumu alttaki gibi listeleyebilecek kodlar icin ornek;

Sub Yorumlari_Listele()

Application.ScreenUpdating = False

Dim yrm_Araligi As Range

Dim Hucre As Range

Dim Asil_Sayfa As Worksheet

Dim Yeni_Sayfa As Worksheet

Dim i As Long

Set Asil_Sayfa = ActiveSheet

On Error Resume Next

Set yrm_Araligi = Asil_Sayfa.Cells _

.SpecialCells(xlCellTypeComments)

On Error GoTo 0

If yrm_Araligi Is Nothing Then

MsgBox "Yorum Bulunamadi"

Exit Sub

End If

Set Yeni_Sayfa = Worksheets.Add

Yeni_Sayfa.Range("A1:D1").Value = _

Array("Adres", "Ad", "Deger", "Yorum")

i = 1

For Each Hucre In yrm_Araligi

With Yeni_Sayfa

i = i + 1

On Error Resume Next

.Cells(i, 1).Value = Hucre.Address

.Cells(i, 2).Value = Hucre.Name.Name

.Cells(i, 3).Value = Hucre.Value

.Cells(i, 4).Value = Hucre.Comment.Text

End With

Next Hucre

Application.ScreenUpdating = True

End Sub
bu konu comment - Yorum haftasi etkinligi dolayisiyla acilmistir..