• DİKKAT

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

Özel Satır Kopyalama

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
M

mbasaranyt

Katılım
15 Kasım 2007
Mesajlar
140
Excel Vers. ve Dili
OFFICE 2019 TR 64 Bit
Dosyam Burada https://yadi.sk/i/q07Uap_C349Yii
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G6:G42]) Is Nothing Then Exit Sub
Satir = Target.Row
Satir1 = Target.Row + 1
Personel = Cells(Satir, 3)
yanıt = MsgBox(Personel & " ' a Ait Bilgiler Arşivlensin mi ?", vbYesNo + vbQuestion, "Seçili Personeli Kopyala")
If yanıt = 6 Then
'K O D L A R ... !
'-----------------------------------------------------------------------------------------------------
End If
End Sub

Bu Sayfadan (G6:G42) arası Çift Tıklama Yaptığım satırı (A:AC) D1 deki ay ismine göre
ilgili sayfaya son satıra yani (12) satır 16 ya Özel Değerleri Yapıştırsın.
 
Son düzenleme:
Merhaba
Örnek dosyanıza göre şöyle denermisiniz?
Kod: 
[SIZE="2"]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G6:G42]) Is Nothing Then Exit Sub
Satir = Target.Row
Satir1 = Target.Row + 1
Personel = Cells(Satir, 3)
yanıt = MsgBox(Personel & " ' a Ait Bilgiler Arşivlensin mi ?", vbYesNo + vbQuestion, "Seçili Personeli Kopyala")
If yanıt = 6 Then
'K O D L A R ... !
'---------------------------------------------------------------------------------------------------------------
ay = Format([D1], "mm")
sat1 = Target.Row
s = Sheets(ay).[C4:C43].SpecialCells(xlCellTypeConstants, 2).Rows.Count
Sheets(ay).Range("A" & s + 4 & ":AC" & s + 5).Value = Range("A" & sat1 & ":AC" & sat1 + 1).Value
Sheets(ay).Cells(s + 4, "B") = s / 2
End If
End Sub [/SIZE]
 
Son düzenleme:
Teşekkür

Üstad Harikasınız çok Teşekkürler.
1- 44 satırda Toplamlar var sıralı kayıt yaptığımda 44 satıra kayıt yapmaması için ne yapmalıyım.
 
Son düzenleme:
s = Sheets(ay).[C4:C43].SpecialCells(xlCellTypeConstants, 2).Rows.Count
bu kısmı [C4:C40] olarak değiştirdim bu seferde ilave yaptıkça son satırı 42. değiştiriyor
 
Merhaba
("s" tanımı
Kod: 
 s = Cells(44, "B").End(3).Row
şeklinde olmalıydı ama
ay sayfalarının; "B" sütununlarında "0" değerleri bulunuyor asıl dosyanızda bunların gerekli olduğunu düşünerek aşağıdaki gibi tanımlandı)

Şöyle deneyelim;
Kod: 
[SIZE="2"]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G6:G42]) Is Nothing Then Exit Sub
[COLOR="Blue"]If ActiveCell.Value = "" Or ActiveCell.Value = "0" Then
MsgBox "Gün Bulunamadı, aktarım yapılamıyor", vbCritical
Exit Sub
End If[/COLOR]
Satir = Target.Row
Satir1 = Target.Row + 1
Personel = Cells(Satir, 3)
yanıt = MsgBox(Personel & " ' a Ait Bilgiler Arşivlensin mi ?", vbYesNo + vbQuestion, "Seçili Personeli Kopyala")
If yanıt = 6 Then
ay = Format([D1], "mm")
sat1 = Target.Row
s = Sheets(ay).[C4:C43].SpecialCells(xlCellTypeConstants, 2).Rows.Count
[COLOR="Blue"]If s + 4 = 44 Then
MsgBox "kayıt sayfası dolu"
Exit Sub
End If[/COLOR]
Sheets(ay).Range("A" & s + 4 & ":AC" & s + 5).Value = Range("A" & sat1 & ":AC" & sat1 + 1).Value
Sheets(ay).Cells(s + 4, "B") = s / 2
End If
End Sub [/SIZE]
 
Teşekkür

PLİNT' Alıntı:
Merhaba
("s" tanımı
Kod: 
 s = Cells(44, "B").End(3).Row
şeklinde olmalıydı ama
ay sayfalarının; "B" sütununlarında "0" değerleri bulunuyor asıl dosyanızda bunların gerekli olduğunu düşünerek aşağıdaki gibi tanımlandı)

Şöyle deneyelim;
Kod: 
[SIZE="2"]Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G6:G42]) Is Nothing Then Exit Sub
[COLOR="Blue"]If ActiveCell.Value = "" Or ActiveCell.Value = "0" Then
MsgBox "Gün Bulunamadı, aktarım yapılamıyor", vbCritical
Exit Sub
End If[/COLOR]
Satir = Target.Row
Satir1 = Target.Row + 1
Personel = Cells(Satir, 3)
yanıt = MsgBox(Personel & " ' a Ait Bilgiler Arşivlensin mi ?", vbYesNo + vbQuestion, "Seçili Personeli Kopyala")
If yanıt = 6 Then
ay = Format([D1], "mm")
sat1 = Target.Row
s = Sheets(ay).[C4:C43].SpecialCells(xlCellTypeConstants, 2).Rows.Count
[COLOR="Blue"]If s + 4 = 44 Then
MsgBox "kayıt sayfası dolu"
Exit Sub
End If[/COLOR]
Sheets(ay).Range("A" & s + 4 & ":AC" & s + 5).Value = Range("A" & sat1 & ":AC" & sat1 + 1).Value
Sheets(ay).Cells(s + 4, "B") = s / 2
End If
End Sub [/SIZE]
Genişletmek için tıkla ...

Üstadım Çok Teşekkürler,Sayfada Gün Olanların Tümünü Nasıl Aktarabilirim
Private Sub CommandButton1_Click()
AnaSayfa = Sheets("Bordro").Range("A6:AC43")
ayadi = Format(Sayfa1.[D1], "m")
Sheets(ayadi).Range("A6:AC43").Value = AnaSayfa
End Sub
 
Butonla aşağıdaki gibi aktaracaktır.
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet
Dim sor As Long
Dim ay As String
Dim a As Range
Dim s As Integer
ay = Format([D1], "m")
sor = MsgBox(ay & "' Ait bilgiler Arşivlensin mi ?", vbYesNo + vbQuestion)
If sor = vbYes Then
Set s1 = Sheets("Bordro")
Set s2 = Sheets(ay)
On Error Resume Next
Application.Calculation = xlCalculationManual
s2.[A6:AC43].ClearContents
s = 4
For Each a In s1.[G6:G42].SpecialCells(xlCellTypeConstants, 1)
If a.Value <> 0 Then
s = s + 2
s2.Range("A" & s & ":AC" & s + 1).Value = s1.Range("A" & a.Row & ":AC" & a.Row + 1).Value
s2.Cells(s, "B") = (s / 2) - 2
End If
Next
Application.Calculation = xlCalculationAutomatic
End If
MsgBox "aktarım bitti"
End Sub [/SIZE]
 
Son düzenleme:
mbasaranyt' Alıntı:
Çok Teşekkür Ederim Şimdi Harika oldu.
Genişletmek için tıkla ...
Rica ederim kolay gelsin.
Gün bulunamadığında ikaz vermesi içinde kodların sonuna şöyle bir ek yapabilirsiniz
Kod: 
'......
Application.Calculation = xlCalculationAutomatic
End If
[COLOR="Blue"]If s = 4 Then
MsgBox "Aktarılacak gün bulunamadı"
Else
MsgBox "aktarım bitti"
End If[/COLOR]
End Sub
 
:hey::hey::hey:
 
Son düzenleme:
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Geri
Üst