relaxim
Altın Üye
- Katılım
- 30 Ağustos 2009
- Mesajlar
- 581
- 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
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