Ayrı ayrı dosyaları makro ile düzeltme

muratuu1982 · 26 Ekim 2023

Merhaba değerli hocalarım,
tek tek dosya şeklinde raporların olduğu bir klasörüm var. Yeni bir dosyada makro ile, bu tek tek olan raporların satır ve sütun büyüklüklerini; sayfa kenar boşluklarını ve yazı boyutunu ayarlayabilmek istiyorum. Rapor sayısı 100-150 kadar olduğundan tek tek uğraşmak uzun süreceğinden böyle bir yol denemek istiyorum.
Destekleriniz için şimdiden teşekkür ederim.

Necdet · 27 Ekim 2023

Merhaba,
Düzenlenmesi istediğiniz dosyaların yapısı aynı ise şöyle yapılabilinir.
Önce düzenlenecek dosyada yapılacak düzenlemeler makro kaydet ile kodlar oluşturulur.
Bu kodlardaki gereksiz fazlalıklar çıkartılır ya da öyle de kalabilir, görmeyince anlamak zor.
Kaydet ile alınan kodlar boş bir dosyaya aktarılar.
Bu dosya ile de tüm dosyalar açılarak düzenleme makrosu çalıştırılır.
Fikir benden

muratuu1982 · 27 Ekim 2023

Necdet' Alıntı:
Merhaba,
Düzenlenmesi istediğiniz dosyaların yapısı aynı ise şöyle yapılabilinir.
Önce düzenlenecek dosyada yapılacak düzenlemeler makro kaydet ile kodlar oluşturulur.
Bu kodlardaki gereksiz fazlalıklar çıkartılır ya da öyle de kalabilir, görmeyince anlamak zor.
Kaydet ile alınan kodlar boş bir dosyaya aktarılar.
Bu dosya ile de tüm dosyalar açılarak düzenleme makrosu çalıştırılır.
Fikir benden

Çok güzel bir fikir oldu teşekkür ederim

.

Dosyalarla ilgili şöyle bir bilgi paylaşayım.
Dosyaların isimleri farklı ama içeriği uzantısı aynı. Bir de hücre boyutları benim istediğim büyüklükte olmalı, otomatik yapınca çok uzun olduğundan sayfaya sığmıyor. Satırı genişletmek de istiyorum metni kaydırmak için.

alicimri · 27 Ekim 2023

1. Ekte Gönderdiğim şablon.xlsm dosyasını, kopya dosyaların oluşmasını istediğiniz klasöre yapıştırın ve istediğiniz formatta düzenleyin.
2. Sayfa1 deki Z sütunu tablonuzun dışında olduğunu düşündüğümden Z1 hücresinden başlayarak oluşmasını istediğiniz dosya isimlerini listeleyiniz.
3. Eğer sayfa isimleri farklı ise kodlardaki "Sheets(Array("Sayfa1", "Sayfa2", "Sayfa3")).Copy" satırını istediğiniz gibi düzenleyin, oluşturmak istediğiniz dosya tek sayfadan oluşuyorsa, "Sheets("Sayfa1").Copy" şeklinde de değiştirebilirsiniz.
4. Makro Ctrl+t ile çalışıyor.
5. Kopya dosyalar .xlsx formatında.

sablon.xlsm dosyasını indir - download

sablon.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

alicimri · 27 Ekim 2023

Yanlış anladım galiba, siz oluşmuş dosyaları biçimlendirmek istiyorsunuz.
Biçimlendirdiğiniz dosyalardan birini şablon olarak kullanmak üzere makro içeren xlsm uzantılı olarak farklı kaydedin.
İçindeki kalıcı verilerin dışındakileri silin.
Aşağıdaki kodları bir modül oluşturup, yapıştırın.
kodlardaki yol = "C:\Users\user\Desktop\Yeni klasör" satırını kendi klasör yoluna göre düzeltin.
Yine kodlardaki Workbooks(1).Sheets(1).Range("A1:F20").Copy satırını size göre değiştirin.

Kod:

Sub format()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim yol As String
yol = "C:\Users\user\Desktop\Yeni klasör"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(yol)
For Each oFile In oFolder.Files
Workbooks.Open Filename:=yol & "\" & oFile.Name
 Workbooks(1).Sheets(1).Range("A1:F20").Copy
   Workbooks(2).Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
  Workbooks(2).Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Workbooks(2).Save
 Workbooks(2).Close
Next oFile
End Sub

Not #4 deki kodlardan yeni dosya oluşturmak için yararlanabilirsiniz.

muratuu1982 · 27 Ekim 2023

alicimri' Alıntı:
Yanlış anladım galiba, siz oluşmuş dosyaları biçimlendirmek istiyorsunuz.
Biçimlendirdiğiniz dosyalardan birini şablon olarak kullanmak üzere makro içeren xlsm uzantılı olarak farklı kaydedin.
İçindeki kalıcı verilerin dışındakileri silin.
Aşağıdaki kodları bir modül oluşturup, yapıştırın.
kodlardaki yol = "C:\Users\user\Desktop\Yeni klasör" satırını kendi klasör yoluna göre düzeltin.
Yine kodlardaki Workbooks(1).Sheets(1).Range("A1:F20").Copy satırını size göre değiştirin.

Kod:

Sub format() Dim oFSO As Object Dim oFolder As Object Dim oFile As Object Dim yol As String yol = "C:\Users\user\Desktop\Yeni klasör" Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFolder = oFSO.GetFolder(yol) For Each oFile In oFolder.Files Workbooks.Open Filename:=yol & "\" & oFile.Name Workbooks(1).Sheets(1).Range("A1:F20").Copy Workbooks(2).Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll Workbooks(2).Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths Workbooks(2).Save Workbooks(2).Close Next oFile End Sub

Not #4 deki kodlardan yeni dosya oluşturmak için yararlanabilirsiniz.

Öncelikle ilginiz için çok teşekkür ederim.
Evet bir klasörde tek tek dosyalar şeklinde sms iletim raporları var, 200-300 kadar. Bu dosyaların İsimleri farklı (dosya isimlerinde sms tarihleri var çınkü) ama uzantıları aynı.

İstiyorum ki, makro ile bu klasördeki dosyaların hücrelerini istediğim ölçülerde yapıp kaydedebileyim, İsimlerinin değişmesi önemli değil.

Sms raporları olduğu için; SMSleri de içeriyor öyle olunca a4e sığmıyor. Sütun daraltıp, satırı biraz genişletip metni kaydır yapacağım. Çıktı alırken A4'e uygun olsun, rahat olsun diye.

alicimri · 27 Ekim 2023

Manuel olarak düzenlemekte olduğunuz dosyaların formatı hep aynı ise (sütun ve satır sayısı, hücre genişlikleri, Metin kaydırılacak hücreler, veriler A" hücresinden başlıyor ve aynı sütunda bitiyor ise) #5 deki açıklamaları uygularsanız. kodlar işinizi görür.
İki üç örnek dosyayı zipleyip, tcdosya gibi bir dosya paylaşım sitesine eklerseniz nihai sonuca çabuk ulaşırsınız.

muratuu1982 · 7 Kasım 2023

alicimri' Alıntı:
Manuel olarak düzenlemekte olduğunuz dosyaların formatı hep aynı ise (sütun ve satır sayısı, hücre genişlikleri, Metin kaydırılacak hücreler, veriler A" hücresinden başlıyor ve aynı sütunda bitiyor ise) #5 deki açıklamaları uygularsanız. kodlar işinizi görür.
İki üç örnek dosyayı zipleyip, tcdosya gibi bir dosya paylaşım sitesine eklerseniz nihai sonuca çabuk ulaşırsınız.

İzahlarınız için teşekkür ederim. Galiba bir şeyleri eksik yapıyorum.
Bu kodu, makro oluşturup yapıştırdım, "yol"u ayarlardım. (yol= raporların içinden seçip olması gerektiği şekle (sütun, satır genişliği vb. anlamında) getirip kaydettiğim dosyanın da içinde bulunduğu klasör. Makroyu çalıştırınca, ekrana dosyalar geliyor, bir şeyler yapıyor, lakin yapmasını istediğimiz eylemleri hiçbir dosyada yapmıyor, yani olmuyor.

Şurası da dikkatimi çekti, Kod görüntüle ekranında "Locals" yazan pencerede "oFile"a "Nothing" yazmış.
En sonunda da, "Aşağıdaki özellikler makro içermeyen bir çalışma kitabına kaydedilemez" > VB Projesi
Durum şu an bu şekilde. Tekrar teşekkür ederim.

alicimri · 8 Kasım 2023

örnek dosyaları ekleyin.

muratuu1982 · 14 Kasım 2023

alicimri' Alıntı:
örnek dosyaları ekleyin.

RaporlamaDeneme.rar dosyasını indir - download

RaporlamaDeneme.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

"Şablon Rapor" isimli dosya taslak-şablon olarak hazırladığım yani makrolu dosya.
Şimdiden teşekkür ederim.

Necdet · 15 Kasım 2023

Merhaba,

Aşağıdaki kodları ister boş bir dosyaya isterseniz sizin şablon olarak belirlediğiniz dosyalara kopyalayabilirsiniz.

Kod düzenleme yapmak istediğiniz dosyaları seçmenizi isteyecek ve biçimlendirecektir.
Birden fazla sayfa olduğunda dikkat etmedim, böyle bir durumda kodlara eklemek gerek, ilgili sayfayı belirlemek gerek.

Kod:

Sub Bicim_Duzenle()
    
    Dim fd  As FileDialog
    Dim dsy As Variant
    Dim adt As Long
    
    Application.ScreenUpdating = False
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Filters.Clear
        .InitialFileName = "C:\"
        .AllowMultiSelect = True
        .Filters.Add "Excel Dosyaları", "*.xl*"
        .FilterIndex = 2    '1 olunca tüm dosyalar, 2 olunca excel  dosyaları
        If .Show = False Then
            MsgBox "Dosya Seçmedin ..... ", vbExclamation
            Exit Sub
        Else
            For Each dsy In .SelectedItems
                adt = adt + 1
                Workbooks.Open (dsy)
                
                Range("A1").RowHeight = 12
                Range("A2").ColumnWidth = 9.67
                Range("B2").ColumnWidth = 8.56
                Range("C2").ColumnWidth = 21.56
                Range("D2").ColumnWidth = 14.11
                Range("E2").ColumnWidth = 10.22
                Range("F2").ColumnWidth = 14.56
                Range("G2").ColumnWidth = 14.56
                Range("H2").ColumnWidth = 57.78
                
                Range("A2:A" & Cells(Rows.Count, "A").End(3).Row).RowHeight = 170.1
                
                With Range("A:H")
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = True
                End With
                            
                ActiveWorkbook.Close Savechanges:=True
            Next dsy
        End If
    End With
    
    Application.ScreenUpdating = True

    If adt > 0 Then MsgBox adt & " ADET DOSYA BİÇİMLENDİRİLDİ...."
    
End Sub

alicimri · 15 Kasım 2023

Aşağıdaki kodu "Şablon Rapor"dosyasına yapıştırın, diğer dosyalarla aynı klasörde bulunmalı

Kod:

Sub format()
On Error Resume Next
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim yol As String
yol = ThisWorkbook.Path
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(yol)
For Each oFile In oFolder.Files
If oFile.Name <> "SablonRapor.xlsm" Then
Workbooks.Open Filename:=yol & "\" & oFile.Name
 Workbooks(1).Sheets(1).Range("A2:H2").Copy
   Workbooks(2).Sheets(1).Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteFormats
  Workbooks(2).Sheets(1).Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteColumnWidths
Workbooks(2).Sheets(1).Range("A1").CurrentRegion.RowHeight = Workbooks(1).Sheets(1).Range("A2").RowHeight
  Workbooks(2).Sheets(1).Rows("1:1").EntireRow.AutoFit
Workbooks(2).Save
 Workbooks(2).Close
 End If
Next oFile
End Sub

muratuu1982 · 16 Kasım 2023

alicimri' Alıntı:

Aşağıdaki kodu "Şablon Rapor"dosyasına yapıştırın, diğer dosyalarla aynı klasörde bulunmalı

Kod:

Sub format()
On Error Resume Next
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim yol As String
yol = ThisWorkbook.Path
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(yol)
For Each oFile In oFolder.Files
If oFile.Name <> "SablonRapor.xlsm" Then
Workbooks.Open Filename:=yol & "\" & oFile.Name
Workbooks(1).Sheets(1).Range("A2:H2").Copy
   Workbooks(2).Sheets(1).Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteAll
  Workbooks(2).Sheets(1).Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteColumnWidths
Workbooks(2).Sheets(1).Range("A1").CurrentRegion.RowHeight = Workbooks(1).Sheets(1).Range("A2").RowHeight
Workbooks(1).Sheets(1).Range("A1:H1").Copy
Workbooks(2).Sheets(1).Range("A1:H1").Insert Shift:=xlDown
  Workbooks(2).Sheets(1).Rows("1:1").EntireRow.AutoFit
Workbooks(2).Save
Workbooks(2).Close
End If
Next oFile
End Sub

Hocam, öncelikle ellerinize sağlık.
Şekil olarak evet boyutlandırma sorunsuz, lakin;
hepsine yani tüm dosyalara "Şablon Rapor" dosyasının 2. satırındaki bilgileri yapıştırıyor tüm dosyaların tüm satırlarına "Şablon Rapor" dosyasının ilk satırının içeriğini.
ayrıca en sona da boyutlandırılmamış bir satır daha ekliyor.
Boyutlandırmada sorun yok lakin bahsettiğim sorun var.
Hedefe yaklaştığımızı düşünüyorum

Çok teşekkür ederim.

Necdet · 16 Kasım 2023

11 Nolu mesaj için görüşlerinizi de rica edeyim.

alicimri · 16 Kasım 2023

Yukarıdaki #12mesajdaki kodları değiştirdim.

muratuu1982 · 16 Kasım 2023

Hocam hem desteğiniz hem de hoşgörünüz için teşekkür ederim. Göremediğim içinse üzgünüm, özür dilerim.

Yazmış olduğunuz kod gayet güzel çalışıyor. Çok teşekkür ederim.

Tıkır tıkır maşallah

Tekrar teşekkür ederim.

Necdet' Alıntı:
11 Nolu mesaj için görüşlerinizi de rica edeyim.

Necdet' Alıntı:

Merhaba,

Aşağıdaki kodları ister boş bir dosyaya isterseniz sizin şablon olarak belirlediğiniz dosyalara kopyalayabilirsiniz.

Kod düzenleme yapmak istediğiniz dosyaları seçmenizi isteyecek ve biçimlendirecektir.
Birden fazla sayfa olduğunda dikkat etmedim, böyle bir durumda kodlara eklemek gerek, ilgili sayfayı belirlemek gerek.

Kod:

Sub Bicim_Duzenle()
   
    Dim fd  As FileDialog
    Dim dsy As Variant
    Dim adt As Long
   
    Application.ScreenUpdating = False
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    With fd
        .Filters.Clear
        .InitialFileName = "C:\"
        .AllowMultiSelect = True
        .Filters.Add "Excel Dosyaları", "*.xl*"
        .FilterIndex = 2    '1 olunca tüm dosyalar, 2 olunca excel  dosyaları
        If .Show = False Then
            MsgBox "Dosya Seçmedin ..... ", vbExclamation
            Exit Sub
        Else
            For Each dsy In .SelectedItems
                adt = adt + 1
                Workbooks.Open (dsy)
               
                Range("A1").RowHeight = 12
                Range("A2").ColumnWidth = 9.67
                Range("B2").ColumnWidth = 8.56
                Range("C2").ColumnWidth = 21.56
                Range("D2").ColumnWidth = 14.11
                Range("E2").ColumnWidth = 10.22
                Range("F2").ColumnWidth = 14.56
                Range("G2").ColumnWidth = 14.56
                Range("H2").ColumnWidth = 57.78
               
                Range("A2:A" & Cells(Rows.Count, "A").End(3).Row).RowHeight = 170.1
               
                With Range("A:H")
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = True
                End With
                           
                ActiveWorkbook.Close Savechanges:=True
            Next dsy
        End If
    End With
   
    Application.ScreenUpdating = True

    If adt > 0 Then MsgBox adt & " ADET DOSYA BİÇİMLENDİRİLDİ...."
   
End Sub

muratuu1982 · 16 Kasım 2023

alicimri' Alıntı:
Yukarıdaki #12mesajdaki kodları değiştirdim.

Çok teşekkür ederim. Gayet güzel oldu. Allah razı olsun. Biraz uğraştırdım emekleriniz için sağ olun.

Ayrı ayrı dosyaları makro ile düzeltme

muratuu1982

Necdet

Moderatör

muratuu1982

alicimri

sablon.xlsm dosyasını indir - download

alicimri

muratuu1982

alicimri

muratuu1982

alicimri

muratuu1982

RaporlamaDeneme.rar dosyasını indir - download

Necdet

Moderatör

alicimri

muratuu1982

Necdet

Moderatör

alicimri

muratuu1982

muratuu1982