• DİKKAT

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

  • Forum yazılımı güncelenmiştir.

    Beklenmedik durumlar görürseniz lütfen yönetime iletin.

Satır arası açan makroda değişiklik

  • Konbuyu başlatan Konbuyu başlatan izcik
  • Başlangıç tarihi Başlangıç tarihi
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Merhabalar

Örnek1 de yıllar önce Sayın Ömer uzmanımın oluşturduğu severek kullandığım bir dosya vardır.

(Bu dosyada A sütunundaki aynı rakamdaki satırların altına, bir boşluk vermektedir. Ve neticeyi Sayfa2 ye aktarmaktadır)

Örnek2 de ise şöyle bir düzeltme yapabilir miyiz?

Yine aynı şekilde A sütunundaki aynı rakamların değil de, aynı isimlerin altına bir boşluk olarak Sayfa2 ye aktaracak. (Örnekte belirttim)

Bu kodları oluşturabilir miyiz?

Teşekkür ederim sağlıklı günler



Örnek 1

https://www.dosya.tc/server27/dwvaw1/ORNEK1.xls.html



Örnek 2

https://www.dosya.tc/server27/633sv1/ORNEK2.xls.html
 
Merhaba
Denermisiniz
Sub Deneme()
Dim S1, S2 As Worksheet
Dim i As Long
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
S2.Cells.ClearContents
Application.ScreenUpdating = False
S1.Cells.Copy S2.Range("A1")
For i = S2.[A65536].End(3).Row To 3 Step -1
If S2.Cells(i, "B") <> S2.Cells(i - 1, "B") Then
S2.Range("A" & i & ":E" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
Application.ScreenUpdating = True
End Sub
 
numan şamil' Alıntı:
Merhaba
Denermisiniz
Sub Deneme()
Dim S1, S2 As Worksheet
Dim i As Long
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
S2.Cells.ClearContents
Application.ScreenUpdating = False
S1.Cells.Copy S2.Range("A1")
For i = S2.[A65536].End(3).Row To 3 Step -1
If S2.Cells(i, "B") <> S2.Cells(i - 1, "B") Then
S2.Range("A" & i & ":E" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...


Sayın Numan Şamil uzmanım tam istediğim gibi. Fikrinize sağlık. Teşekkür ederim.

Eğer mümkünse bir de, neticeyi Sayfa2 ye değil de, aynı sayfaya yani Sayfa1 e dökecek şekilde kodları yazabilir misiniz. İkisini de kullanmak istiyorum.
 
Merhaba
Sayfa1 deki listede direk satır boşluğu oluşturmak için
Sub Deneme1()
Dim i As Long
Application.ScreenUpdating = False
For i =[A65536].End(3).Row To 3 Step -1
If Cells(i, "B") <>Cells(i - 1, "B") Then
Range("A" & i & ":E" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
Application.ScreenUpdating = True
End Sub
 
Uzmanım hiç eksiksiz oldu. Sağolunız. Sağlıklı günler dilerim.
Saygılar
 
Ben uzman değilim bildiğimiz kadarıyla yardımcı olmaya çalışıyorum
İyi çalışmalar
 
teşşekkür ederim hayırlı çalışmalar
 
Sayın izcik
Sayfa1 sayfasındaki verilerde direk olarak her butona batığınızda peşpeşe boş satırlar eklemesini istemiyorsanız aşağıdaki kodları
kullanabilirsiniz
Sub Deneme1()
Dim i As Long
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
If Cells(i, "B") <> "" And Cells(i - 1, "B") <> "" Then
If Cells(i, "B") <> Cells(i - 1, "B") Then
Range("A" & i & ":E" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
 
numan şamil' Alıntı:
Sayın izcik
Sayfa1 sayfasındaki verilerde direk olarak her butona batığınızda peşpeşe boş satırlar eklemesini istemiyorsanız aşağıdaki kodları
kullanabilirsiniz
Sub Deneme1()
Dim i As Long
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
If Cells(i, "B") <> "" And Cells(i - 1, "B") <> "" Then
If Cells(i, "B") <> Cells(i - 1, "B") Then
Range("A" & i & ":E" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...

Sayın uzmanım çok güzel çok kullanışlı olmuş. Üstelik farkında olduğum, ama dile getirmeye çekindiğim bir minik sorunu siz istemeye gerek kalmadan düzeltmiş oldunuz. Bu daha güzel bir jest oldu.

Birazdan yeni bir konu açacağım, hazırlık yapıyorum. (Eski kullandığım dosyalardaki makrolarda düzeltme ile ilgili.

Çok teşekkür ederim. İyi günler
 
Peki Numan uzmanım eğer zahmet olmazsa
rakamları sayfa1 de ayıranın kodlarındaki ”peşpeşe boş satır ekleme” sorununu da düzeltebilir misiniz?
....


(sadece rakamları sayfa 1 de ayıran kodlar)

Sub Deneme()
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
Say = Cells(i, "A") - Cells(i - 1, "A")

If Say <> 0 Then
Say = Say - 1
Rows(i & ":" & i + Say).Insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
End Sub
 
Merhaba
Denermisiniz
Sub Deneme()
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
Say = Cells(i, "A") - Cells(i - 1, "A")
If Cells(i, "A") <> "" And Cells(i - 1, "A") <> "" Then
If Say <> 0 Then
Say = Say - 1
Rows(i & ":" & i + Say).Insert Shift:=xlDown
End If
End If
Next
Application.ScreenUpdating = True
End Sub
 
numan şamil' Alıntı:
Merhaba
Denermisiniz
Sub Deneme()
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
Say = Cells(i, "A") - Cells(i - 1, "A")
If Cells(i, "A") <> "" And Cells(i - 1, "A") <> "" Then
If Say <> 0 Then
Say = Say - 1
Rows(i & ":" & i + Say).Insert Shift:=xlDown
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...

Sayın uzmanım bu da rakamlar için çok güzel olmuş. Saygıar sunarım ilginiz ve yardımlarınız için
 
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst