- Katılım
- 5 Eylül 2007
- Mesajlar
- 1,247
- Excel Vers. ve Dili
- ofis 2010
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Makro ile rapor alma işlemi yapılıyor, onda sonra biçimlendirme değişiyor.Muhtemelen kopyala-yapıştırdan sonra oluyor.
Kopyalama yaptğınızda sadece verileri yapıştırmayı deneyin.
Farklı bir çözümü var mı biliyorum ama ek olarak kod yazılabilir.Her işlemden sonra biçimlendirmeyi silip tekrar yapacak şekilde.
=$A1>1 Uygulama Hedefi =$A$1:$F$100Kodları yazarmısınız?
Kodları demiştim ama ?Makro ile rapor alma işlemi yapılıyor, onda sonra biçimlendirme değişiyor.
Kodları demiştim ama ?
Sub İŞLEM_BRN()
Set ul = Sheets("URUN_LISTE"): Set sb = Sheets("sabitler"): Set ha = Sheets("HAREKET")
ul.Range("A2:F" & ul.Cells(65536, 1).End(3).Row).ClearContents
Application.ScreenUpdating = False
sb.Range("B2:D" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Copy ul.Range("A2")
For i = 2 To ul.Range("A65536").End(xlUp).Row
ha.Cells(1, 1) = ul.Cells(i, 1): ul.Cells(i, 4) = ha.Cells(1, "P"): ul.Cells(i, 5) = ha.Cells(1, "Q")
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub
Sub Carp()
On Error Resume Next
Application.EnableEvents = False
Dim Bak As Long
For i = 2 To [A2000].End(3).Row
With Worksheets("URUN_LISTE")
.Cells(i, "F").Value = Cells(i, "D").Value * Cells(i, "E").Value
End With
Next
Range("F:F").NumberFormat = "#,##0.00"
Application.EnableEvents = False
End Sub
ul.Range("A2:C" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value = sb.Range("B2:D" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value
değişme olmadıKod:ul.Range("A2:C" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value = sb.Range("B2:D" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value
Olarak denermisiniz?
Deneme başarısız olursa örnek dosya üzerinden gidelim.Muhtemelen buradaki kopyalamada diğer sayfadaki biçimlendirmeyi de alıyor.
dosyayı atabilirmisiniz
Sub İŞLEM_BRN()
Set ul = Sheets("URUN_LISTE"): Set sb = Sheets("sabitler"): Set ha = Sheets("HAREKET")
ul.Range("A2:F" & ul.Cells(65536, 1).End(3).Row).ClearContents
Application.ScreenUpdating = False
ul.Range("A2:C" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value = sb.Range("B2:D" & sb.Cells(Rows.Count, "B").End(xlUp).Row).Value
For i = 2 To ul.Range("A65536").End(xlUp).Row
ha.Cells(1, 1) = ul.Cells(i, 1): ul.Cells(i, 4) = ha.Cells(1, "P"): ul.Cells(i, 5) = ha.Cells(1, "Q")
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Teşekkürler, bu şekilde olduad tanimlamadan alan belirleyin öyle deneyin.
Rica ederim Kolay gelsinTeşekkürler, bu şekilde oldu