boşluktan sonraki satırları bir sonraki boşluğa kadar kopyalayıp transpozesini almak

[fhrsym]

arkadaşlar merhaba;
Sorunum şu; Elimde 10000 tane data var . Bu dataların hepsi birer boşluk bırakılarak alt alta yazılmış. Boşlukların belli bir düzeni yok( 5 satır sonra bir boşluk gibi düzenli gitmiyor). Boşluktan sonraki satırları kopyalayıp transpozesini almam gerekiyor. İlkinin transpozesini alıp makroyu kaydettim. Daha sonrakiler için for next döngüsü yazıp sornu çözebileceğimi düşünüyorum ama bir türlü beceremedim. Yardımcı olursanız çok sevinirim.

Herkese iyi çalışmalar;

 

[Ömer]

Merhaba,

Sorunuzu küçük bir örnek dosya ekleyerek olması gereken biçimle birlikte açıklayınız.

 

[Trilenium]

Sayın fhrsym, size daha çabuk yardımcı olması amacıyla; İlgili boşlugu hücre icinde iken seçiniz ve CTRL+C yaparak kopyalayınız. Daha sonra ilgili sütun yada satirlari seçerek CTRL+H yapınız
aranacak deger kopyaladıgınızı boşlugu yapıştırınız, yeni degere hiçbirşey yazmayınız ve tümünü degiştir diyiniz. Bitti bukadar.. boşluklar uçmuştur.

 

[fhrsym]

For i = 1 To 3
c = dizi(i - 1) + 1
cc = dizi(i) - 1
Range("A"&c:"A"cc).Select
Selection.Copy
Range("C" & i + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next i


Yukarıdaki kod bloğunu yazdım. Ancak 4. satırdaki range kısmında iki nokta koyamıyorum hata veriyor program. virgül koydoğumda çalışıyor ama sadece başlangıç ve bitiş hücrelerini kopyalıyor. Range kısmına iki nokta koyup çalıştırabilirsem sanırım sorunum çözülecek ama iki gündür uğraşıyorum yapamadım. Yardımcı olursanız çok sevinirim

 

[Trilenium]

Arkadaşım neden kod kullanıyorsun anlamadım ki ? 2 saniyelik iş bu

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

Aşağıdaki kod uygulanmıştır.

A sütunundaki boş satır içeren verileri eleyip dolu hücreleri C sütununa listeler.

Option Explicit
 
Sub BOS_SATIRLARI_KALDIR()
    Dim Alan As Range, Say As Long, Satir As Long
 
    ReDim Dizi(1 To 1)
    Range("C:C").ClearContents
    Satir = Cells(Rows.Count, 1).End(3).Row
 
    For Each Alan In Range("A1:A" & Satir)
        If Alan.Value <> "" Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To Say)
            Dizi(Say) = Alan.Value
        End If
    Next
 
    If Say > 0 Then Range("C1").Resize(Say) = Application.Transpose(Dizi)
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[fhrsym]

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

Aşağıdaki kod uygulanmıştır.

A sütunundaki boş satır içeren verileri eleyip dolu hücreleri C sütununa listeler.

Option Explicit
 
Sub BOS_SATIRLARI_KALDIR()
    Dim Alan As Range, Say As Long, Satir As Long
 
    ReDim Dizi(1 To 1)
    Range("C:C").ClearContents
    Satir = Cells(Rows.Count, 1).End(3).Row
 
    For Each Alan In Range("A1:A" & Satir)
        If Alan.Value <> "" Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To Say)
            Dizi(Say) = Alan.Value
        End If
    Next
 
    If Say > 0 Then Range("C1").Resize(Say) = Application.Transpose(Dizi)
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sanırım sorunumu tam anlamıyla anlatamadım. Aşağıdaki dosyada küçük bi örnek gönderiyorum. Bunu yapabilmek için yazdığım kod da şu şekilde

Sub fSH()
'
' fSH Makro
'
Dim Counter
Dim i As Integer
Dim m As Integer
Dim k As Integer
Dim cc As Integer
Dim c As Integer
Dim j As Integer

Dim dizi() As Integer

k = 0
m = 0
Counter = InputBox("Enter the total number of rows to process")
ActiveCell.Select
For i = 1 To Counter
' Checks to see if the active cell is blank.
If ActiveCell = "" Then
m = m + 1
Else
' Selects the next cell.
ActiveCell.Offset(1, 0).Select
End If
Next i

ReDim dizi(m) As Integer

For i = 1 To Counter

If ActiveCell = "" Then
dizi(k) = i
k = k + 1
Else
' Selects the next cell.
ActiveCell.Offset(1, 0).Select
End If
Next i


Range("A1:A6").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

For i = 1 To Counter
c = dizi(i - 1) + 1
cc = dizi(i) - 1
Range("A"&c:"A"&cc).Select
Selection.Copy
Range("C" & i + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next i

End Sub

 

[Ömer]

Bu şekilde deneyin.

Sub duzenle()
 
    Dim i As Long, say As Long, j As Long
 
    say = Columns("A:A").SpecialCells(xlCellTypeBlanks).Count
 
    Application.ScreenUpdating = False
    Range(Cells(1, "F"), Cells(Rows.Count, Columns.Count)).Clear
 
    j = 1
    For i = 1 To say + 1
        If Cells(j, "A") <> "" Then
            Range("A" & j & ":A" & Cells(j, "A").End(xlDown).Row).Copy
            Cells(i, "F").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            j = Cells(j, "A").End(xlDown).Row + 2
        End If
    Next i
 
    Range("A1").Select
    With Application
        .ScreenUpdating = True
        .CutCopyMode = False
    End With
 
End Sub

.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub AKTAR()
    Dim X As Long, Satir As Long, Satir_1 As Long, Satir_2 As Long
    
    Application.ScreenUpdating = False

    Range("F:IV").Clear
    Satir = 1
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        If Cells(X, 1) <> "" Then Satir_1 = X
        Do While Cells(X, 1) <> ""
            Satir_2 = X
            X = X + 1
        Loop
    
        If Satir_1 > 0 And Satir_2 > 0 Then
            Range("A" & Satir_1, "A" & Satir_2).Copy
            Cells(Satir, "F").PasteSpecial Paste:=xlPasteAll, Transpose:=True
            Satir = Satir + 1
            Application.CutCopyMode = False
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[fhrsym]

ilginiz için çok teşekkür ederim. Korhan bey size ayrıca teşekkür ederim son yazmış olduğunuz kod bloğu sorunumu çözdü. İyi çalışmalar