info uit rijen naar kolommen

[dimiris]

ik heb een query gedaan op een database en de outcome geexporteerd naar excel.
nu heb ik twee rijen met overlappende info.
Ik wil graag de NIET overlappende info op de eerste rij in twee nieuwe kolommen.
zie bijlageBekijk bijlage QW_HelpMijInfoRijenKolommen.xls
Maar hoe doe ik dat? Ik ben redelijk handig met excel, maar beheers nauwelijks VB.

Ik hoop dat hier een oplossing voor is.

 

[alberto10]

Beste,
Plaats onderstaande code in een module :

Sub Test()
    Set currentCell = Range("A3")
    Do While Not IsEmpty(currentCell)
        Set nextCell = currentCell.Offset(1, 0)
        If nextCell.Value = currentCell.Value Then
            currentCell.EntireRow.Delete
        End If
        Set currentCell = nextCell
    Loop
End Sub

 

[Warme bakkertje]

Sub ontdubbel()
  With Sheets("Blad1")
    sq = .Cells(1, 1).CurrentRegion
    For j = 1 To UBound(sq) - 1
        c0 = c0 & sq(j, 1): c1 = c1 & sq(j + 1, 1)
        If c0 = c1 Then sq(j, 1) = ""
        c0 = "": c1 = ""
    Next
    .Cells(1, 1).CurrentRegion = sq
    .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  End With
End Sub

 

[dimiris]

Bedankt Alberto10 en warm bakkertje, ik ga er maandag mee stoeien.
Jullie horen of het gelukt is.

 

[dimiris]

Beste helpers,
Ik heb eindelijk wat tijd gevonden om verder met het probleem te stoeien. Sorry voor deze vertraging.
Jullie oplossing werkt om de dubbelingen er uit te halen. De informatie uit de cellen H4, I4 en heb ik echter wel nodig. Het liefst door ze te tonen in J3,K3.
Idem met de informatie uit H6,I6 die ik getoond wil hebben in J5,K5
De rest van regel 4 en 6 mag dan gedelete worden.
Zoals in regel 11 en 12 van het voorbeeld

Ik hoop dat ik jullie hierin niet overvraag; het is nu nog veel handwerk. Dat kost tijd en geeft kans op fouten.

 

[sylvester-ponte]

zo iets?

Sub Test()
    Dim currentCell As Range, Temp As Range
    Set currentCell = Range("A3")
    Do While Not IsEmpty(currentCell)
        If currentCell(2, 1) = currentCell Then
            Set Temp = currentCell(1, 255).End(xlToLeft)(1, 2)
            Do
                 Set currentCell = currentCell(1, 2)
                 If currentCell <> currentCell(2, 1) Then
                    currentCell(2, 1).Copy Temp
                    Set Temp = Temp(1, 2)
                 End If
            Loop Until currentCell.Column = 9
            currentCell(2, 1).EntireRow.Delete
            Set currentCell = currentCell(1, -7)
        Else
            Set currentCell = currentCell(2, 1)
        End If
    Loop
End Sub

groet sylvester

 

[dimiris]

ongelooflijk!

Beste Sylvester,
Ik begrijp het script vrijwel geheel..NIET, maar het werkt en daar ben ik hartstikke blij en geholpen mee.

Dank je wel voor je expertise en de tijd die je hebt genomen om mij te helpen.

met vriendelijke groet,
Dimitri