- Katılım
- 10 Temmuz 2011
- Mesajlar
- 12
- Excel Vers. ve Dili
-
2002
tr
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Test()
Dim X As Long
For X = 2 To Cells(Rows.Count, "N").End(3).Row Step 3
If Cells(X, "N") <> "" Then
Cells(X + 1, 1) = Cells(X, "N")
Cells(X + 1, 1).Font.Size = Cells(X, "N").Font.Size
Cells(X + 1, 1).Font.Bold = Cells(X, "N").Font.Bold
Cells(X + 1, 1).Font.Color = Cells(X, "N").Font.Color
Cells(X, "N") = ""
End If
Next
MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub
N2 ----> AM3 birleştirilmişe taşındı lakin bazılarında olduDeneyiniz.
C++:Option Explicit Sub Test() Dim X As Long For X = 2 To Cells(Rows.Count, "N").End(3).Row Step 3 If Cells(X, "N") <> "" Then Cells(X + 1, 1) = Cells(X, "N") Cells(X + 1, 1).Font.Size = Cells(X, "N").Font.Size Cells(X + 1, 1).Font.Bold = Cells(X, "N").Font.Bold Cells(X + 1, 1).Font.Color = Cells(X, "N").Font.Color Cells(X, "N") = "" End If Next MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation End Sub
bana verilen excel de iki değişiklik yapacağım.Paylaştığınız görselde satırlar düzenli artıyordu. Uyguladığınız dosyanızda bu durum farklı ise sonuç almamaniz normaldir.
Örnek dosyanızı paylaşırsanız kodu ona göre revize edebilirim. Paylaşım sitelerine örnek dosyanızı yükleyip linkini forumda paylaşabilirsiniz.
Korhan bey paylaştım Excel dosyasını öncesi ve sonrası diye, görmemiş olabilirsiniz diye hatırlatma yapayım dedim. İyi çalışmalar.bana verilen excel de iki değişiklik yapacağım.
1. ilk satır hariç sonraki satırların herbirinin arasına A dan N ye kadar (N dahil değil) birleştirilmiş tek hücre oluşturarak eklemek.
2. N sütunundaki Metin leri sırasıyla 1.de oluşturulan birleştirilmiş tek hücreye sırasıyla taşımak. Sonunda tabloyu A dan M ye kadar (M sütunu dahil) kullanmak yani N sütunu işlemin en sonunda sileceğim. Umarım açıklayıcı olurken akıl karıştırmamışımdır. Teşekkürler , Kolay gelsin
excel dosyasının öncesi
excel dosyasının son hali
Option Explicit
Sub Baslik_Ekle()
Dim Metin As Variant, X As Long, Satir As Long, Son As Long
Application.ScreenUpdating = False
Range("A2:M" & Rows.Count).UnMerge
Son = Cells(Rows.Count, "N").End(3).Row
Metin = Range("N2:N" & WorksheetFunction.Max(3, Son)).Value
Satir = 3
For X = LBound(Metin, 1) To UBound(Metin, 1)
Range("A" & Satir & ":M" & Satir).Merge True
Range("A" & Satir) = Metin(X, 1)
Range("A" & Satir).Font.Name = "Verdana"
Range("A" & Satir).Font.Size = 16
Range("A" & Satir).Font.Bold = True
Satir = Satir + 2
Next
Range("N2:N" & Rows.Count).ClearContents
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır."
End Sub
Option Explicit
Sub Baslik_Ekle()
Dim Alan As Range, Metin As Variant, X As Long, Satir As Long, Son As Long
Application.ScreenUpdating = False
Son = Cells(Rows.Count, "N").End(3).Row
Metin = Range("N2:N" & WorksheetFunction.Max(3, Son)).Value
Range("A2:M" & Rows.Count).UnMerge
On Error Resume Next
Set Alan = Nothing
Set Alan = Intersect(Range("A:M"), Range("B2:B" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(4).EntireRow)
On Error GoTo 0
If Not Alan Is Nothing Then Alan.Delete xlUp
Satir = 3
For X = LBound(Metin, 1) To UBound(Metin, 1)
If Metin(X, 1) <> "" Then
Range("A" & Satir).EntireRow.Insert
Range("A" & Satir & ":M" & Satir).Merge True
Range("A" & Satir) = Metin(X, 1)
Range("A" & Satir).Font.Name = "Verdana"
Range("A" & Satir).Font.Size = 16
Range("A" & Satir).Font.Bold = True
End If
Satir = Satir + 2
Next
Range("N2:N" & Rows.Count).ClearContents
Set Alan = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır."
End Sub