Çift tıkla taşıma

[muratgunay48]

Arkadaşlar, sayın hocalarım, çift tıkla kopyaladım, yapıştırdım. Oraya kadar yazdım. Ama boşluk kalmasın da tıkandım. B sütununda olanı çift tıkla alacağım istediğim hücreye çift tıkla yapıştıracağım.
Takıldığım nokta şurası. Örneğin B'den kesince boşluk kalmayacak. Aşağıdakiler yukarı kayacak.
Yardımcı olursanız sevinirim.
Şimdiden teşekkür ederim.
Saygılarımla.

 

[volki_112]

Arkadaşlar, sayın hocalarım, çift tıkla kopyaladım, yapıştırdım. Oraya kadar yazdım. Ama boşluk kalmasın da tıkandım. B sütununda olanı çift tıkla alacağım istediğim hücreye çift tıkla yapıştıracağım.
Takıldığım nokta şurası. Örneğin B'den kesince boşluk kalmayacak. Aşağıdakiler yukarı kayacak.
Yardımcı olursanız sevinirim.
Şimdiden teşekkür ederim.
Saygılarımla.

istediğiniz şekilde düzenledim. Ekten indirebilirsiniz. Kullandığım kod

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Static HafizaDeger As Variant
    Static HafizaAdres As String
    Static KopyalamaAktif As Boolean
   
    Dim sonSatir As Long
    Dim sonSatirA As Long
   
    If Target.Cells.Count > 1 Then Exit Sub
    Cancel = True

    ' B sütununda çift tıklayınca kopyala
    If KopyalamaAktif = False And Target.Column = 2 Then
       
        HafizaDeger = Target.Value
        HafizaAdres = Target.Address
        KopyalamaAktif = True
       
    ' Başka yerde çift tıklayınca yapıştır
    ElseIf KopyalamaAktif = True Then
       
        Target.Value = HafizaDeger
       
        ' Kaynak hücreyi sil ve yukarı kaydır
        Range(HafizaAdres).Delete Shift:=xlUp
       
        KopyalamaAktif = False
       
        ' A2 formülünü aşağı uzat
        sonSatir = Cells(Rows.Count, "B").End(xlUp).Row
       
        If Range("A2").HasFormula Then
            Range("A2").AutoFill Destination:=Range("A2:A" & sonSatir)
        End If
       
        ' A sütunundaki son dolu hücreyi sil
        sonSatirA = Cells(Rows.Count, "A").End(xlUp).Row
        If sonSatirA >= 2 Then
            Cells(sonSatirA, "A").ClearContents
        End If
       
    End If

End Sub

 

[muratgunay48]

istediğiniz şekilde düzenledim. Ekten indirebilirsiniz. Kullandığım kod

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Static HafizaDeger As Variant
    Static HafizaAdres As String
    Static KopyalamaAktif As Boolean
  
    Dim sonSatir As Long
    Dim sonSatirA As Long
  
    If Target.Cells.Count > 1 Then Exit Sub
    Cancel = True

    ' B sütununda çift tıklayınca kopyala
    If KopyalamaAktif = False And Target.Column = 2 Then
      
        HafizaDeger = Target.Value
        HafizaAdres = Target.Address
        KopyalamaAktif = True
      
    ' Başka yerde çift tıklayınca yapıştır
    ElseIf KopyalamaAktif = True Then
      
        Target.Value = HafizaDeger
      
        ' Kaynak hücreyi sil ve yukarı kaydır
        Range(HafizaAdres).Delete Shift:=xlUp
      
        KopyalamaAktif = False
      
        ' A2 formülünü aşağı uzat
        sonSatir = Cells(Rows.Count, "B").End(xlUp).Row
      
        If Range("A2").HasFormula Then
            Range("A2").AutoFill Destination:=Range("A2:A" & sonSatir)
        End If
      
        ' A sütunundaki son dolu hücreyi sil
        sonSatirA = Cells(Rows.Count, "A").End(xlUp).Row
        If sonSatirA >= 2 Then
            Cells(sonSatirA, "A").ClearContents
        End If
      
    End If

End Sub

Hocam emeğinize sağlık. Yalnız muhtemelen ben yanlış anlattım. H ya da K ya da M sütunundan kesmiyor. Herhangi bir hücreden kesecek herhangi bir hücreye yapıştıracak. Aşağıdakiler yukarı kayacak.

 

[Korhan Ayhan]

Deneyiniz.

 

[muratgunay48]

Deneyiniz.

Hocam diyecek söz bulamıyorum. Çok ama çok teşekkür ederim.

 

[muratgunay48]

Deneyiniz

Hocam soluna sıra numarası yazdım. Dinamik. İsmi kesince neden bozuluyor. Bir türlü çözemedim.
=EĞER(B2="";"";SATIR()*1)-1

 

[Korhan Ayhan]

Paylaştığım dosyada onunda çözümü var..

 

[volki_112]

Hocam soluna sıra numarası yazdım. Dinamik. İsmi kesince neden bozuluyor. Bir türlü çözemedim.
=EĞER(B2="";"";SATIR()*1)-1

korhan hocamın dosya ile birleştirdim benimkini. buna bakabilirsiniz. formül bozulma işini de vba ile düzeltme ekledim

 

[muratgunay48]

Paylaştığım dosyada onunda çözümü var..

Hocam teşekkür ederim. Geç cevap için özür dilerim. Sitede erişim sorunu vardı.

 

[muratgunay48]

korhan hocamın dosya ile birleştirdim benimkini. buna bakabilirsiniz. formül bozulma işini de vba ile düzeltme ekledim

Hocam çok teşekkür ederim. Sağ olun.