Sadece değerleri aktarsın. (Formüller, biçimler hariç)

R

relaxim

Altın Üye
Katılım
30 Ağustos 2009
Mesajlar
579
Excel Vers. ve Dili
Ofis 2016 Tr 64 bit
Altın Üyelik Bitiş Tarihi
15.06.2027
Merhaba bu siteden arkadaşların yardımıyla kullanmakta olduğun dosyada bir kaç deneme yaptım.
Ancak sadece değerleri değil formüllerde kopyalayıp yapıştırıyor.. Yardımcı olabilir misiniz?
Özellikle Sip sayfasında E ve M sütunundaki formüller var... Sevk sayfasında F ve N sütununa yapıştırıyor.

Private Sub CommandButton1_Click()
Dim i, j As Integer: Dim sf1, sf2 As Worksheet
Dim ss, lr As Integer: Dim zaman As Double
zaman = Timer
Set sf1 = Worksheets("SİP")
Set sf2 = Worksheets("SEVK")
ss = sf1.Range("M65000").End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To ss
If sf1.Cells(i, "M").Value = "FAZLA" Or sf1.Cells(i, "M").Value = "KAPANDI" Then
sf1.Range("A" & i & ":M" & i).Cut
sf2.Activate
lr = sf2.Range("B65000").End(xlUp).Row + 1
sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
On Error Resume Next
sf2.Range("B" & lr).Activate
Worksheets("SEVK").Paste
Application.CutCopyMode = False
End If
If sf1.Cells(i, "M").Value = "KISMEN" And sf1.Cells(i, "K").Value <> "" Then
sf1.Range("A" & i & ":M" & i).Copy
sf2.Activate
lr = sf2.Range("B65000").End(xlUp).Row + 1
sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
On Error Resume Next
sf2.Range("B" & lr).Activate
Worksheets("SEVK").Paste
Application.CutCopyMode = False
sf1.Cells(i, "F").Value = sf1.Cells(i, "N").Value
sf1.Cells(i, "K").Value = ""
sf1.Cells(i, "L").Value = ""
End If
Next i

'boş satırları temizleme makrosu
' For j = 100 To 2 Step -1
For j = ss To 2 Step -1
If sf1.Cells(j, 2) = "" Then
Rows(j & ":" & j).Delete Shift:=xlUp
End If
Next j


MsgBox "İstenilen Bilgiler Aktarıldı..!" & vbCrLf & "Boş Satırlar Silindi..!" & vbNewLine & "İşlem Süresi. " & Format(zaman - Timer, "0:00") & " Saniye", vbInformation, Environ("Username")

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
271
Excel Vers. ve Dili
Excel 2021 Türkçe
Dener misiniz;

Kod: 
Private Sub CommandButton1_Click()
    Dim i, j As Integer: Dim sf1, sf2 As Worksheet
    Dim ss, lr As Integer: Dim zaman As Double
    
    zaman = Timer
    Set sf1 = Worksheets("SİP")
    Set sf2 = Worksheets("SEVK")
    ss = sf1.Range("M65000").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For i = 2 To ss
        If sf1.Cells(i, "M").Value = "FAZLA" Or sf1.Cells(i, "M").Value = "KAPANDI" Then
            ' Değerleri geçici bir değişkende saklayalım
            Dim tempValues As Variant
            tempValues = sf1.Range("A" & i & ":M" & i).Value
            
            sf2.Activate
            lr = sf2.Range("B65000").End(xlUp).Row + 1
            sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
            
            sf2.Range("B" & lr & ":M" & lr).Value = tempValues
            
            sf1.Rows(i).Delete
            i = i - 1
            ss = ss - 1
        End If
        
        If sf1.Cells(i, "M").Value = "KISMEN" And sf1.Cells(i, "K").Value <> "" Then
            Dim tempValuesKismen As Variant
            tempValuesKismen = sf1.Range("A" & i & ":M" & i).Value
            
            sf2.Activate
            lr = sf2.Range("B65000").End(xlUp).Row + 1
            sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
            
            sf2.Range("B" & lr & ":M" & lr).Value = tempValuesKismen
            
            sf1.Cells(i, "F").Value = sf1.Cells(i, "N").Value
            sf1.Cells(i, "K").Value = ""
            sf1.Cells(i, "L").Value = ""
        End If
    Next i
    
    For j = ss To 2 Step -1
        If sf1.Cells(j, 2) = "" Then
            sf1.Rows(j).Delete Shift:=xlUp
        End If
    Next j
    
    MsgBox "İstenilen Bilgiler Aktarıldı..!" & vbCrLf & "Boş Satırlar Silindi..!" & vbNewLine & "İşlem Süresi. " & Format(zaman - Timer, "0:00") & " Saniye", vbInformation, Environ("Username")
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
444
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
relaxim' Alıntı:
Merhaba bu siteden arkadaşların yardımıyla kullanmakta olduğun dosyada bir kaç deneme yaptım.
Ancak sadece değerleri değil formüllerde kopyalayıp yapıştırıyor.. Yardımcı olabilir misiniz?
Özellikle Sip sayfasında E ve M sütunundaki formüller var... Sevk sayfasında F ve N sütununa yapıştırıyor.

Private Sub CommandButton1_Click()
Dim i, j As Integer: Dim sf1, sf2 As Worksheet
Dim ss, lr As Integer: Dim zaman As Double
zaman = Timer
Set sf1 = Worksheets("SİP")
Set sf2 = Worksheets("SEVK")
ss = sf1.Range("M65000").End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To ss
If sf1.Cells(i, "M").Value = "FAZLA" Or sf1.Cells(i, "M").Value = "KAPANDI" Then
sf1.Range("A" & i & ":M" & i).Cut
sf2.Activate
lr = sf2.Range("B65000").End(xlUp).Row + 1
sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
On Error Resume Next
sf2.Range("B" & lr).Activate
Worksheets("SEVK").Paste
Application.CutCopyMode = False
End If
If sf1.Cells(i, "M").Value = "KISMEN" And sf1.Cells(i, "K").Value <> "" Then
sf1.Range("A" & i & ":M" & i).Copy
sf2.Activate
lr = sf2.Range("B65000").End(xlUp).Row + 1
sf2.Range("A" & lr).Value = sf2.Range("A" & lr - 1).Value + 1
On Error Resume Next
sf2.Range("B" & lr).Activate
Worksheets("SEVK").Paste
Application.CutCopyMode = False
sf1.Cells(i, "F").Value = sf1.Cells(i, "N").Value
sf1.Cells(i, "K").Value = ""
sf1.Cells(i, "L").Value = ""
End If
Next i

'boş satırları temizleme makrosu
' For j = 100 To 2 Step -1
For j = ss To 2 Step -1
If sf1.Cells(j, 2) = "" Then
Rows(j & ":" & j).Delete Shift:=xlUp
End If
Next j


MsgBox "İstenilen Bilgiler Aktarıldı..!" & vbCrLf & "Boş Satırlar Silindi..!" & vbNewLine & "İşlem Süresi. " & Format(zaman - Timer, "0:00") & " Saniye", vbInformation, Environ("Username")

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
Genişletmek için tıkla ...
Kodunuzda
Worksheets("SEVK").Paste satırını silip yerine alttakini yazınız
Worksheets("SEVK").PasteSpecial Paste:=xlPasteValues
 
R

relaxim

Altın Üye
Katılım
30 Ağustos 2009
Mesajlar
579
Excel Vers. ve Dili
Ofis 2016 Tr 64 bit
Altın Üyelik Bitiş Tarihi
15.06.2027
Sn Volki_112 hızlı dönüş için teşekkür ederim. Boş satır açıp yapıştırmadı.
Ben de
PasteSpecial xlValues denemiştim aynısı oldu.
Müsait olunca örneği ekleyeyim.

İlk verdiğiniz kodlar sürekli hata verdi.
 

Ekli dosyalar

R

relaxim

Altın Üye
Katılım
30 Ağustos 2009
Mesajlar
579
Excel Vers. ve Dili
Ofis 2016 Tr 64 bit
Altın Üyelik Bitiş Tarihi
15.06.2027
Merhaba,

Maalesef boş kayıt yaptı. Müsait olunca bakbilir misiniz?
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst