- Katılım
- 18 Ağustos 2009
- Mesajlar
- 740
- Excel Vers. ve Dili
- Office Ev ve İş 2021 - Türkçe
- Altın Üyelik Bitiş Tarihi
- 12-12-2024
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Hata veren satırı silin.
Sonrasında döngü içindeki Selection yazan yere Cells yazıp deneyiniz.
cogalt'ın içine tipdegisikligi ni eklesemde yine oluşturulan dosyadan değilde orjinal dosyadan temizliyor bir türlü olmadı hocam. Neyse sağlık olsun ne diyelim.O zaman sizde koda yeni oluşturulan sayfayı seçen komutu yazmayı deneyiniz.
Ne yaptığınızı bilmediğimden afaki cevaplar veriyorum.
Örnek dosya paylaşırsanız durumu daha net anlayıp doğru cevap verebiliriz.
Sub cogalt()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For k = 1 To Application.Sheets.Count
If IsNumeric(Sheets(k).Name) Then
sayisal = sayisal + 1
Else
harf = harf + 1
End If
Next k
Tespit = InputBox("Çoğaltılacak Gün Sayısı", "DENEME")
For i = sayisal To Tespit + sayisal - 1
Sheets(CStr(sayisal)).Select
Sheets(CStr(sayisal)).Copy Before:=Sheets(1)
Sheets(1).Name = i + 1
Sheets(1).Range("P1") = Sheets("1").Range("P1") + i
Sheets(1).Range("M3:N11,P3:P11,M13:N40,P13:P40,M42:N72,P42:P72,M80:N135,P80:P135,W4:X9,Z4:Z9,AB4:AB14,Z13:Z15,AA20,AD4:AD24,AF4:AF25").ClearContents
If numlock = True Then CreateObject("Wscript.Shell").SendKeys "{NUMLOCK}"
fnd = Array("Tip Değişikliği", "Malzeme Bekleme", "Ayar-Ölçme Odası")
rplc = Array("", "", "")
For j = LBound(fnd) To UBound(fnd)
Sheets(1).Cells.Replace fnd(j), rplc(j), xlPart
Next j
Next i
For j = 1 To Application.Sheets.Count - harf
On Error Resume Next
Sheets(CStr(j)).Select
Sheets(CStr(j)).Move Before:=Sheets(j)
Next j
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub