eşitleme ve düzenleme

[saratbey]

a sütünü ve b sütününda veriler var verilerin aynı sütünda kalması koşuluyla aynı değerde olan verilerin yan yana gelmesi karşılığı olmayan verilerin karşılarının boş kalması gerekiyor. bunu excelde yapabilme şansımız varmıdır. sıkıntımı daha iyi anlata bilmek için ekde excel dosyası gönderiyorum. bana yardımcı olursanız minnettler kalırım saygılarımla

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırın.

Sub Duzenle()
 
    Dim son As Long, i As Long, say As Long, frk As Long
    Dim c As Range, deg As Double, sat As Long
 
    Application.ScreenUpdating = False
    Range("E1:F" & Rows.Count).Clear
 
    son = Cells(Rows.Count, "A").End(xlUp).Row
 
    Range("A2:B" & son).Sort Range("A2")
 
    Range("A1:A" & son).AdvancedFilter Action:=xlFilterCopy, _
                    CopyToRange:=Range("E1"), Unique:=True
 
    Range("E1") = "Düzenlenmiş Hali"
 
    frk = Range("A2") - CDbl(Right(Range("B2"), 7))
    sat = Range("A2")
 
    If frk > 0 Then
        Range("E2:E" & frk + 1).Insert Shift:=xlDown
        sat = CDbl(Right(Range("B2"), 7))
    End If
 
    For i = Cells(Rows.Count, "E").End(xlUp).Row To 3 Step -1
        If Cells(i, "E") <> "" And Cells(i - 1, "E") <> "" Then
            say = Cells(i, "E") - Cells(i - 1, "E")
            If say > 1 Then
                say = say - 2
                Range("E" & i & ":E" & i + say).Insert Shift:=xlDown
            End If
        End If
    Next i
 
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Right(Cells(i, "B"), 7)
        Set c = Range("E:E").Find(deg, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Cells(c.Row, "F") = Cells(i, "B")
        Else
            Cells(deg - sat + 2, "F") = Cells(i, "B")
        End If
    Next i
 
End Sub

.

 

[saratbey]

eline sağlık ömer bey teşekkürler

 

[saratbey]

ömer bey hata veriyor 400 eror diyor

 

[Ömer]

Hata veren dosyayı eklermisiniz.