Kapalı Dosyada Satır Silme / Satır Ekleme

[BedriA]

Arkadaşlar,

Ekteki dosyada veriler arasında boş satır bulunuyor.
Ben bu dosyayı makro ile başka bir dosyaya aktarıyorum ve aralarında boş satır olması sıkıntı yaratıyor.

Bu dosyayı başka sayfaya aktarmadan önce, seçeceğim klasördeki tüm excel dosyalarında, userform üzerindeki bir buton yardımıyla şunu yapmak istiyorum:

1- Boş satırları Sil
2- 1. Satıra boş satır ekle

Ekteki dosyadan istediğim daha iyi anlaşılacaktır.

 

[askm]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm_Boş_Sil()
Dim sonsat As Long
sonsat = Range("A65536").End(xlUp).Row
For i = sonsat To 1 Step -1
If Cells(i, 1) = Empty Then
    Rows(i).Delete
End If
Next i
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[Asri]

Alternatif;

Tüm excel dosyalarına belirli bir makroyu uygulamak için bu konudaki programı kullanabilirsiniz.

http://www.excel.web.tr/f52/excel-tum-excel-dosyalarynda-makro-aly-tyrma-t161511.html

Uygulanacak makro da aşağıdaki şekildedir.

* Satır silmek için her bir satırda en son dolu kolona kadar boş olma şartı aranır.

Sub Uygulanacak_Makro()
 On Error Resume Next
 ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
 For i = ensonsatir To 1 Step -1
      j = WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, ensonsutun)))
      If j = 0 Then Rows(i).Delete
 Next i
 
 Rows("1:1").Select
 Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1").Select
End Sub

 

[BedriA]

Aşağıdaki kodları kullanabilirsiniz.

Sub askm_Boş_Sil()
Dim sonsat As Long
sonsat = Range("A65536").End(xlUp).Row
For i = sonsat To 1 Step -1
If Cells(i, 1) = Empty Then
    Rows(i).Delete
End If
Next i
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

Hocam teşekkürler.

Bu makroyu seçeceğim klasördeki tüm excel dosyalarına nasıl uygulayacağım?

 

[BedriA]

Alternatif;

Tüm excel dosyalarına belirli bir makroyu uygulamak için bu konudaki programı kullanabilirsiniz.

http://www.excel.web.tr/f52/excel-tum-excel-dosyalarynda-makro-aly-tyrma-t161511.html

Uygulanacak makro da aşağıdaki şekildedir.

* Satır silmek için her bir satırda en son dolu kolona kadar boş olma şartı aranır.

Sub Uygulanacak_Makro()
 On Error Resume Next
 ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
 For i = ensonsatir To 1 Step -1
      j = WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, ensonsutun)))
      If j = 0 Then Rows(i).Delete
 Next i
 
 Rows("1:1").Select
 Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1").Select
End Sub

Satır silme ve ekleme makrosu sorunsuz çalışıyor.
Ancak ben seçeceğim klasördeki tüm excel dosyalarına bu makro uygulansın istiyorum. Verdiğiniz linki uyarlamaya çalıştım, yapamadım.
Ayrıca ben userform kullanıyorum, kullanıcı excel sayfalarını görmüyor yani.

 

[Asri]

Satır silme ve ekleme makrosu sorunsuz çalışıyor.
Ancak ben seçeceğim klasördeki tüm excel dosyalarına bu makro uygulansın istiyorum. Verdiğiniz linki uyarlamaya çalıştım, yapamadım.
Ayrıca ben userform kullanıyorum, kullanıcı excel sayfalarını görmüyor yani.

Kod olarak aşağıdaki şekildedir.
Tüm alt klasörler dahil arar ve işlem yapar.

'VBA Reference  dan Microsoft scripting runtime seçili olmalı.

Dim dosya As String

Sub menu()
 With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Excel dosyalarının bulunduğu klasörü seçiniz."
        .Show
        If .SelectedItems.Count <> 0 Then
           Process_XLS_Files .SelectedItems(1)
        End If
    End With
End Sub

Private Sub Process_XLS_Files(folderPath As String)
     
    Dim Folder As Scripting.Folder, Subfolder As Scripting.Folder, File As Scripting.File
    Dim wb As Workbook
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(folderPath)
    
    If Folder.subfolders.Count > 0 Then
      For Each Subfolder In Folder.subfolders
        For Each File In Subfolder.Files
            If InStr(File.Name, ".xls*") > 0 Then
               dosya = File
               Call bos_satir_sil
            End If
        Next
      Next
     Else
     
        For Each File In Folder.Files
            If InStr(File.Name, ".xls") > 0 Then
                dosya = File
                Call bos_satir_sil
            End If
        Next
     
     End If
End Sub


Sub bos_satir_sil()
 On Error Resume Next
 Workbooks.Open (dosya)
 ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
 For i = ensonsatir To 1 Step -1
      j = WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, ensonsutun)))
      If j = 0 Then Rows(i).Delete
 Next i
 
 Rows("1:1").Select
 Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1").Select
 ActiveWorkbook.Save
 ActiveWorkbook.Close
End Sub

 

[BedriA]

Kod olarak aşağıdaki şekildedir.
Tüm alt klasörler dahil arar ve işlem yapar. C:\deneme\test i kendinize göre değiştirin.

Dim dosya As String

Sub menu()
    Process_XLS_Files "C:\deneme\test"
End Sub

Private Sub Process_XLS_Files(folderPath As String)
     
    Dim Folder As Scripting.Folder, Subfolder As Scripting.Folder, File As Scripting.File
    Dim wb As Workbook
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(folderPath)
    
    If Folder.subfolders.Count > 0 Then
      For Each Subfolder In Folder.subfolders
        For Each File In Subfolder.Files
            If InStr(File.Name, ".xls*") > 0 Then
               dosya = File
               Call bos_satir_sil
            End If
        Next
      Next
     Else
     
        For Each File In Folder.Files
            If InStr(File.Name, ".xls") > 0 Then
                dosya = File
                Call bos_satir_sil
            End If
        Next
     
     End If
End Sub


Sub bos_satir_sil()
 On Error Resume Next
 Workbooks.Open (dosya)
 ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
 For i = ensonsatir To 1 Step -1
      j = WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, ensonsutun)))
      If j = 0 Then Rows(i).Delete
 Next i
 
 Rows("1:1").Select
 Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1").Select
 ActiveWorkbook.Save
 ActiveWorkbook.Close
End Sub

Bilgisayar içindeki herhangi bir klasörü seçemiyorum sanırım bu kod ile. Doğru mu hocam?

 

[Asri]

Bilgisayar içindeki herhangi bir klasörü seçemiyorum sanırım bu kod ile. Doğru mu hocam?

Kod klasör seçimi yapılacak şekilde güncellendi.

 

[BedriA]

Kod klasör seçimi yapılacak şekilde güncellendi.

Hocam çok teşekkürler.

Son bir soru: Bu kodları userform üzerindeki bir butonla çalıştırmam mümkün mü?

 

[Asri]

Hocam çok teşekkürler.

Son bir soru: Bu kodları userform üzerindeki bir butonla çalıştırmam mümkün mü?

Butonun koduna

call menu

ekleyin.

 

[BedriA]

Butonun koduna

call menu

ekleyin.

Asri Hocam,

ekteki dosyaya açılışta userform geliyor.
Ben beceremedim, size zahmet kodu butona atayabilir misiniz?

 

[Asri]

Asri Hocam,

ekteki dosyaya açılışta userform geliyor.
Ben beceremedim, size zahmet kodu butona atayabilir misiniz?

Dosya mesaja eklendi.

VBA Reference dan Microsoft scripting runtime seçili olmalı.

 

[BedriA]

Dosya mesaja eklendi.

VBA Reference dan Microsoft scripting runtime seçili olmalı.

Asri Hocam,

Çok teşekkür ederim.
Bu programı kullanacak kişilerde dediğiniz seçenek seçili değilse program çalışmayacak mı? Yoksa hazırladığım programda benim seçmiş olmam yeterli mi?

 

[Asri]

Asri Hocam,

Çok teşekkür ederim.
Bu programı kullanacak kişilerde dediğiniz seçenek seçili değilse program çalışmayacak mı? Yoksa hazırladığım programda benim seçmiş olmam yeterli mi?

Bu kodlar hangi excel dosyasında çalışacak ise orada seçilmiş olması yeterli.

satırlarını sileceğinizi excel dosyalarında bu tanımı yapmanız gerekmiyor.

 

[BedriA]

Bu kodlar hangi excel dosyasında çalışacak ise orada seçilmiş olması yeterli.

satırlarını sileceğinizi excel dosyalarında bu tanımı yapmanız gerekmiyor.

Çok çok teşekkür ederim Asri hocam.
Elinize, zihninize sağlık.