Makro = Boş satır ekle

[Baggwell]

Merhabalar

Bir kopyalama makrosu oluşturdum,

Tek sorun kırmızı ile belirttiğim yerde oluşuyor,

Ben yapıştırırken bir önceki verinin altına bir satır ekleyip öyle yapıştır dedim.

Ama makromuz Bir önceki veririnin en alt satırına boş bir satır ekliyor. Dolayısı ile araya eklemiş oluyor, veriyi de buraya kopyalıyor.

Bunu nasıl düzeltebilrim ;

Sub Makro3()
'
' Makro3 Makro
'

'
    Sheets("ML").Select
    Rows("31:31").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    
    Range("A1").Select
    Selection.End(xlDown).Select
  [COLOR="Red"]  Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove[/COLOR]
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    

End Sub

 

[acar6783]

Sub KOPYALA()
 sds = Sheets("Data").Range("A65536").End(xlUp).Row
 bs = sds + 1
Set KPSTR = Sheets("ML").Rows("31:31")
Range(KPSTR, KPSTR.End(xlDown)).Copy Sheets("Data").Range("A" & bs)
 
End Sub

bu kod işinizi çözecektir

 

[Murat OSMA]

acar6783'e Bilgi:

bs = sds + 1 ile başka bir değişken kullanmak yerine

bu şekilde sds değişkeninin sonuna +1 yazabilirsiniz;
sds = Sheets("Data").Range("A65536").End(xlUp).Row + 1

dolayısıyla bu satırı da Range(KPSTR, KPSTR.End(xlDown)).Copy Sheets("Data").Range("A" & sds) yaparsınız...

 

[acar6783]

E öğrenicez inşalah sayenizde hocam

 

[Baggwell]

Murat bey sizin kodunuzu uyguladım fakat makro çalışmıyor sorunu çözemedim rica etsem bakabilirmisiniz

sayın acar sizde kod çalışıyor mu ?

 

[acar6783]

Sub KOPYALA()
 sds = Sheets("Data").Range("A65536").End(xlUp).Row+1
 Set KPSTR = Sheets("ML").Rows("31:31")
Range(KPSTR, KPSTR.End(xlDown)).Copy Sheets("Data").Range("A" & sds)
 
End Sub

olarak deneyin

 

[Baggwell]

Benimde aklıma son anda sayfa isimlerini düzenlemek gelmişti denedim öyle olmadı ,
Bir de böyle denedim olmadı

Sub Yedekle()
'
' Makro3 Makro
'
    sds = Sheets("Data").Range("A65536").End(xlUp).Row + 1
    Sheets("ML").Select
    Rows("31:31").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    Range("A1").Select
    Selection.End(xlDown).Select
    Range(ML, ML.End(xlDown)).Copy Sheets("Data").Range("A" & sds)
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    

End Sub

 

[acar6783]

hocam dosya eklermisiniz...
kod çalışıyor bir sıkıntı yok siz koda ek yapmanıza gerek yok
ML sayfasındaki 33. satırdan itibaren dolu olan hücreleri kopyalayıp Data sayfasındaki son dolu hücreye boş satır ekleyip yapıştırıyor...

 

[Baggwell]

hocam dosya eklermisiniz...
kod çalışıyor bir sıkıntı yok siz koda ek yapmanıza gerek yok
ML sayfasındaki 33. satırdan itibaren dolu olan hücreleri kopyalayıp Data sayfasındaki son dolu hücreye boş satır ekleyip yapıştırıyor...

Siz böyle deyince boş çalışma kitabında denedim makro gerçektende tam istediğim şekilde çalışıyor

Benim dosyada acaba diğer makro ile mi çakışıyor onu tespit etmeye çalışıp bilgi döneceğim hocam

 

[Baggwell]

İlginç çalışmıyor.


Aşağıdaki kodu kullanıyorum oluyor,

Bende data sayfasında en üst ve en alta birer değer verdim.

arasına kopyalıyor o şekilde mi devam edeceğim ne yapayım bilemedim

Sub Yedekle()
'
' Makro3 Makro
'

'
    Sheets("ML").Select
    Rows("31:31").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Data").Select
    
    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    

End Sub

 

[acar6783]

Hocam kodda sıkıntı yok fakat siz eski yazdığınız kodu siliyomusunuz yeniyi eklediğinizde

 

[Baggwell]

Evet hocam,

Sayfada sadece sizin makronuz var, benim dosyada sorun var sanırım

 

[acar6783]

Dosyayı ekleyin bir bakalım olur mu?
Ya da kod hangi satırda hata veriyor?

 

[Baggwell]

Hocam paylaşmak isterdim ama kişisel bilgiler çok fazla, 6 sayfa formüllerle çalışıyor ve her sayfada resim getirme makrosu var. değerleri silersem formüller çalışmayacak bu seferde size göndereceğim dosya aynı olmayacak ama hangi satırda hata verdiğini göstereyim, lütfen yanlış anlamayın yardımcı olmak istediğiniz için çok teşekkürler

Excel 2013 kullanıyorum, veriyi tablodan kopyalayıp - dataya yapıştırmak (diğer makroyu kaydederek oluşturmuştum çalışıyordu ama bunda nedense hata veriyor )

bir ilgisi olabilir mi

 

[Baggwell]

Dosyamda bulunan resim çekme makrosu da bu şekilde, forumdaki bir paylaşımdan almıştım Allah razı olsun ona da

Bu makro engel olabilir mi?

Option Explicit



Private Sub Worksheet_Activate()

hucre_sil_engelle
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim adrs As Integer
On Err GoTo sonhata
Dim ds As String

hucre_sil_engelle
    Image1.PictureSizeMode = fmPictureSizeModeStretch
    


        


     If IsError(Range("x8").Value) Then
     Exit Sub
     End If

          If Dir$(ThisWorkbook.Path & "\perresim\" & Range("x8").Value & ".jpg") = "" Then

        
             Image1.Visible = False
    
              Exit Sub
                  

                 
                  Else
                  Image1.Visible = True
                     Image1.Picture = LoadPicture(ThisWorkbook.Path & "\perresim\" & Range("x8") & ".jpg")
                   End If
  

    Exit Sub
sonhata:
   Exit Sub
    Resume


End Sub



Sub hucre_sil_engelle()


        Range("M1").Select

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'hucre_sil_engelle
End Sub

 

[acar6783]

Burada hücre sil engelle diye bir satur var belki odur diyecem ama diyemiyorum
Şöyle yapsak
Siz dosyanzidaki tum sayfalari shift ile secin hepsini temizleyin ki veri kalmasın sonra farkli kaydedip buraya yukleyin

Kodlar falan kalsın sadece özel bilgileri silin

 

[Baggwell]

Dosya boyutu rarlı olarak 1.86mb

Buradan dosyayı indirebilirsiniz > Google.

Gmail hesabınızı öğrenebilirmiyim