boş satır sil makrosunu , farklı kaydet makrosuna entegre etme

[by_IsTaNBuL]

On Error Resume Next
[b3:b20].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
On Error GoTo 0

yukarıdaki boş satır silme makrosunu aşagıdaki masaüstüne farklı kaydet makrosuna nasıl monte edeceğim yardımcı olurmusunuz



Sub farklıkaydetprof()
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")


deger = InputBox("dosyanın adı adını değiştirebilirsiniz.", "UYARI!", Worksheets("PROF").Range("V184").Value)
deger1 = InputBox("Sayfanın adını değiştirebilirsiniz.", "UYARI!", "MAİL")
'dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = "PROF-MAİL"
'-------------------------------

Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
msg = "Lütfen bir klasör seçiniz."
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Lütfen bir klasör seçiniz."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
Klasor = Left(Path, pos - 1)

Else
MsgBox "işlemi iptal ettiniz."
Exit Sub
End If


Dim FileExtStr As String
Dim FileFormatNum As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For i = Len(ThisWorkbook.Name) To 1 Step -1
'For i = 1 To Len(ThisWorkbook.Name)
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next

Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook
Dim sayfa As Worksheet
For Each sayfa In Worksheets

If sayfa.Name = Sayfa_Adı Then

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & "\" & deger & Uzanti)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else

sayfa.Copy
'ActiveSheet.Copy

Dim wb As Workbook
Set wb = ActiveWorkbook

With wb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'MsgBox "HATA VAR"
FileExtStr = Right(Sourcewb.Name, 5)
FileFormatNum = 52
'Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

With wb

If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If


Sheets(ActiveSheet.Name).Name = deger1

.SaveAs Klasor & "\" & deger & FileExtStr, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
'MsgBox "Kayıt yeri " & Klasor & "\" & deger & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End If
Next

 

[Korhan Ayhan]

Merhaba,

Eğer makro başlangıcında boş hücreler silinecekse aşağıdaki satırdan hemen sonrasına belirttiğiniz kodları ekleyin. Eğer başka işlemlerden sonra silinecekse bunu belirtirseniz uygun yeri tarif edebiliriz.

Sub farklıkaydetprof()

Not: Foruma kod eklerken düz yazı şeklinde değilde [ code ] Kodlarınız... [/ code ] mavi bölümler arasına yazarsanız kod penceresinde görünür. (Siz boşluk kullanmayın.)

 

[by_IsTaNBuL]

korhan bey

korhan bey silinecek satırlar masaüstüne kaydedilen sayfada olacak yani ana dosyada hiç bir bir değişiklik olmayacak.

sadece masa üstüne kaydettiğim dosyadaki sayfada fazlalık kalan satırlar silinecek.

 

[halit3]

On Error Resume Next
[b3:b20].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
On Error GoTo 0

yukarıdaki boş satır silme makrosunu aşagıdaki masaüstüne farklı kaydet makrosuna nasıl monte edeceğim yardımcı olurmusunuz

Sorunuz eksik bilgilerle dolu bu kadar uzun bir kod ekliyorsunuz örnek dosyanızı eklemiyorsunuz
daha sonra ekliyeceğiniz silme makrosu var diyorsunuz . Hangi prosüdürün içine yani sayfa adı veya modül adını bildirmiyorsunuz .
Sil makro kodu eksik adı ney başka hangi bölümleri var bildirmiyorsunuz.
İlgili makronuzun aşağıdaki bölümüne kırmızı bölümü ekleyiniz.

If yer = vbYes Then

ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
[COLOR=red]If moddul <> "ThisWorkbook" Then
ekle = component.CodeModule
End If[/COLOR]
modul.DeleteLines 1, modul.CountOfLines
End If
Next
[COLOR=red]ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 1, "Sub sil()"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 2, "On Error Resume Next"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 3, "[b3:b20].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 4, "End Sub"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 5, "On Error GoTo 0"
[/COLOR]End If

yada aşağıdaki bölümü siliniz.

[COLOR=red]modul.DeleteLines 1, modul.CountOfLines[/COLOR]

 

[halit3]

Yada Bu bölümü

If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End If

bununla değiştirin

If yer = vbYes Then
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
If moddul <> "ThisWorkbook" Then
ekle = component.CodeModule
End If
modul.DeleteLines 1, modul.CountOfLines
End If
Next
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 1, "Sub sil()"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 2, "On Error Resume Next"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 3, "[b3:b20].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 4, "End Sub"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 5, "On Error GoTo 0"
End If

yada Sheets(ActiveSheet.Name).Name = deger1 bundan önce aşağıdaki kodu ekle

ekle = Worksheets(1).CodeName
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 1, "Sub sil()"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 2, "On Error Resume Next"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 3, "[b3:b20].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 4, "End Sub"
ActiveWorkbook.VBProject.VBComponents(ekle).CodeModule.InsertLines 5, "On Error GoTo 0"

not:'Referanslardan Microsoft visual Basic for Applications Extensibility x.x seçin

 

[halit3]

Soruyu soran arkadaş
Yukarıdaki bu kodlar işini gördümü acaba.?

 

[by_IsTaNBuL]

malesef

malesef gömedi halit bey