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

[izcik]

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

 

[numan şamil]

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

 

[izcik]

Hemen deniyorum.

 

[izcik]

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

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.

 

[numan şamil]

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

 

[izcik]

Uzmanım hiç eksiksiz oldu. Sağolunız. Sağlıklı günler dilerim.
Saygılar

 

[karaca1981]

Merhaba ekli dosya da yardımcı olabilirmisiniz

 

[numan şamil]

Ben uzman değilim bildiğimiz kadarıyla yardımcı olmaya çalışıyorum
İyi çalışmalar

 

[karaca1981]

teşşekkür ederim hayırlı çalışmalar

 

[numan şamil]

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

 

[izcik]

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

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

 

[numan şamil]

İyi Çalışmalar

 

[izcik]

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

 

[izcik]

Örnek

RAKAMLARI_SAYFA1_DE_AYIRAN.xls dosyasını indir - download

RAKAMLARI_SAYFA1_DE_AYIRAN.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[numan şamil]

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

 

[izcik]

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

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

 

[numan şamil]

İyi çalışmalar