• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makroya ilave

kemalist

kemalist

Katılım
4 Haziran 2008
Mesajlar
798
Excel Vers. ve Dili
Excel 2021 TÜRKÇE
Arkadaşlar Merhaba;benim yapmak istediğim "SİL" isimli dosyadan yani bu sayfadan "DATALAR " dosyasındaki istenilen sayfadan seçili hücreler arasını silmek yani temizlemek.Yukarıdaki makro ile aynı dosya içinde yapabiliyorum.Bu makroyu istemiş olduğum şekilde değişiklik yapabilirmiyiz? Örnek dosya ektedir.İlginiz için şimdiden teşekkür ederim....
 

Ekli dosyalar

Buyurun.:cool:
Kod: 
Sub SATIRSECSİL59()
birinci = Range("c8").Value 'SAYFA
ikinci = Range("e8").Value 'BAŞLANGIÇ HÜCRESİ
üçüncü = Range("g8").Value 'BİTİŞ HÜCRESİ
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\DATALAR.xlsx").ReadOnly = True Then
    Workbooks("DATALAR.xlsx").Close True
End If
Application.DisplayAlerts = True
Workbooks("DATALAR.xlsx").Sheets(birinci).Range(ikinci & ":" & üçüncü).ClearContents
ThisWorkbook.Activate
End Sub
 
Sub SATIRSECSİL59()
birinci = Range("c8").Value 'SAYFA
ikinci = Range("j10").Value 'BAŞLANGIÇ HÜCRESİ
üçüncü = Range("l10").Value 'BİTİŞ HÜCRESİ
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\LERTER.xlsm").ReadOnly = True Then
Workbooks("LERTER.xlsm").Close True
End If
Application.DisplayAlerts = True
Workbooks("LERTER.xlsm").Sheets(birinci).Range(ikinci & ":" & üçüncü).ClearContents
ThisWorkbook.Activate

End Sub

Sayın Orion1 makroda dosya tipini değiştirdikten sonra hata veriyor bu arada her iki dosyada açık durumda çalıştırmaya çalıştım.İlginiz için şimdiden teşekkür ederim.
 
Son düzenleme:
Sayın Orion1 her iki çalışma kitabını bir dosyada toplayınca sorun çözüldü.
 
Sub HÜCRE_TEMİZLE_EMAS()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için

SEÇSİL_EMAS1
SEÇSİL_EMAS2

Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True

End Sub

Sub SEÇSİL_EMAS1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için
birinci = Range("c8").Value 'SAYFA
ikinci = Range("j10").Value 'BAŞLANGIÇ HÜCRESİ
üçüncü = Range("l10").Value 'BİTİŞ HÜCRESİ
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\LERTER.xlsm").ReadOnly = True Then
Workbooks("LERTER.xlsm").Close True
End If
Application.DisplayAlerts = True
Workbooks("LERTER.xlsm").Sheets(birinci).Range(ikinci & ":" & üçüncü).ClearContents
ThisWorkbook.Activate
Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True
End Sub

Sub SEÇSİL_EMAS2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için
birinci = Range("c8").Value 'SAYFA
ikinci = Range("j12").Value 'BAŞLANGIÇ HÜCRESİ
üçüncü = Range("l12").Value 'BİTİŞ HÜCRESİ
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\LERTER.xlsm").ReadOnly = True Then
Workbooks("LERTER.xlsm").Close True
End If
Application.DisplayAlerts = True
Workbooks("LERTER.xlsm").Sheets(birinci).Range(ikinci & ":" & üçüncü).ClearContents
ThisWorkbook.Activate
Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True
End Sub

Sayın Orion1;iki tane benzer makroyu birlikte çalıştırmak istedim. Yanlız makro çalışsada birincinin sildiği veriler geri geliyor, ikincisi siliniyor.Makroları tek tek çalıştırdığımda çalışıyor.
Bu sorun için nasıl bir değişiklik yapılabilir?
İlginiz için şimdiden teşekkür ederim.
 
Örnek dosyanızı ekleyerek sıkıştırıp yollayınız.:cool:
 
Dosya ektedir.
Buyurun.:cool:
Kod: 
Sub HÜCRE_TEMİZLE_EMAS()
Dim i As Integer, sonsat As Long, wb As Workbook, sh As Worksheet
Dim birinci As String, ikinci As String
sonsat = Cells(Rows.Count, "J").End(xlUp).Row
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\LERTER.xlsm").ReadOnly = True Then
    Workbooks("LERTER.xlsm").Close True
End If
Application.DisplayAlerts = True
ThisWorkbook.Activate
Set wb = Workbooks("LERTER.xlsm")
Set sh = wb.Sheets(Range("C8").Value)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için
For i = 10 To sonsat Step 2
    birinci = Cells(i, "J").Value
    ikinci = Cells(i, "L").Value
    If birinci = "" Then GoTo atla
    If ikinci = "" Then GoTo atla
    sh.Range(birinci & ":" & ikinci).ClearContents
atla:
Next i
Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True
wb.Save
Set sh = Nothing
Set wb = Nothing
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Sayın Orion1;Önce ilginiz için teşekkür ederek başlamak istiyorum makro normal olarak çalışıyor fakat hedef hücreleri değiştirip çalıştırdığımızda önceki silinen hücreler geri geliyor.Birde "LERTER"e çalışma sayfası ekleyip çalıştırdığımızda hata veriyor,çalışmıyor.
 
kemalist' Alıntı:
Sayın Orion1;Önce ilginiz için teşekkür ederek başlamak istiyorum makro normal olarak çalışıyor fakat hedef hücreleri değiştirip çalıştırdığımızda önceki silinen hücreler geri geliyor.Birde "LERTER"e çalışma sayfası ekleyip çalıştırdığımızda hata veriyor,çalışmıyor.
Genişletmek için tıkla ...

Hangi hedef hücreleri?
Bir kaç tane örnek verebilirmisiniz?
 
Başlangıç hücreleri için C10 hücresine Sütun,D10 hücresine Satır;Bitiş hücreleri için G10 hücresine Sütun ,H10 hücresine Satır için giriyorum.J10 ve L10 hücrelerinde BİRLEŞTİR formülü ile birleştirip Başlangıç ve Bitiş Hücrelerini oluşturuyorum.
 
kemalist' Alıntı:
Başlangıç hücreleri için C10 hücresine Sütun,D10 hücresine Satır;Bitiş hücreleri için G10 hücresine Sütun ,H10 hücresine Satır için giriyorum.J10 ve L10 hücrelerinde BİRLEŞTİR formülü ile birleştirip Başlangıç ve Bitiş Hücrelerini oluşturuyorum.
Genişletmek için tıkla ...

dosyayı 10 nolu mesajdan indirebilirsiniz.
Not:Sayfa eklediğimde bir sorun olmadı.:cool:
 
Sayın Orion1 birde örnekteki dosyaya bakarmısınız?
 

Ekli dosyalar

kemalist' Alıntı:
Sayın Orion1 birde örnekteki dosyaya bakarmısınız?
Genişletmek için tıkla ...

ilk hedef için kodlar aşağıdadır.
Kolay gelsin.:cool:
Kod: 
Sub KAYIT()
Dim sh As String, hcr As String, dosya As String
ThisWorkbook.Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'hızlandırmak için
dosya = Range("P9").Value
sh = Range("s9").Value 'SAYFA
hcr = Range("m9").Value 'HEDEF HÜCRESİ

Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\KAYIT.xlsm").ReadOnly = True Then
    Workbooks("KAYIT.xlsm").Close True
End If
Application.DisplayAlerts = True
ThisWorkbook.Activate
Range("I3:IX3").Copy
Workbooks(dosya & ".xlsm").Sheets(sh).Range(hcr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False
ThisWorkbook.Activate
Application.Calculation = xlCalculationAutomatic 'hızlandırmak için
Application.ScreenUpdating = True
End Sub
 
Teşekkür ederim Oron1.İyi çalışmalar.Emeğinize sağlık...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst