CODEWITHSUNDEEP
excelvbatranspose
Zerkaden
Zerkaden

Reputation: 23

Excel macro to transpose specific cells from row to column

I am working with data from an image analysis software which exports data in the following way :

SampleImage

In every case, two empty rows separate the Image name from the different annotations put on the Image itself. The next Image is separated from the last annotation by three empty rows. All annotations are refered to by their number and consist of a measurement, its unit and a comment about which kind of measurement it is. However, this disposition is not practical. It would be much easier to manage the data if it were displayed like this:

SampleImage2

In the form of a table with "Annotation", "Comment", "Value" and "Unit" as headers, with all information about the annotation in the same row. So far I've tried to transpose the data manually, but this takes way too long when many images are involved. I also tried to use the macro recorder to automate the process, but it doesn't work since it uses fixed positions in the worksheet. Moreover, all Images don't possess the same number of annotations.

Could anyone help me create a macro to do such a thing? I've started dabbling with the VBA code recently, but this is way out of my league.

Upvotes: 2

Views: 3738

Answers (2)

L42
L42

Reputation: 19737

I already mentioned I'll post a possible solution so here it goes (although kinda late).

Sub Test()
    Dim lr As Long, r As Range
    Application.ScreenUpdating = False
    With Sheet1 'source worksheet; change to suit
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set r = .Range("A1:D" & lr)
        r.Replace "Length", "": r.AutoFilter 1, "<>"
        r.SpecialCells(xlCellTypeVisible).Copy Sheet4.Range("A1")
        .AutoFilterMode = False
        r.AutoFilter 2, "<>"
        r.Offset(0, 2).Resize(, 1).SpecialCells(xlCellTypeVisible).Copy _
            Sheet4.Range("E1")
        .AutoFilterMode = False
    End With

    With Sheet4 'output worksheet; change to suit
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        .Range("B1:B" & lr).Copy: .Range("E1:E" & lr).PasteSpecial xlPasteValues, , True
        .Range("E1:E" & lr).Replace "Attribute Name", "Comment"
        .Range("E1:E" & lr).Cut .Range("B1")
        .Range("C1:C" & lr).AutoFilter 1, "<>"
        .Range("D2:D" & lr).SpecialCells(xlCellTypeVisible).Replace "", "Unit"
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

This will work if the data is as consistent as what you've posted above.
Also result will be something like this (no space between Image name).
Also it needs an output worksheet (in above case it is Sheet4). HTH.

enter image description here

Upvotes: 0

Wiktor Stribiżew
Wiktor Stribiżew

Reputation: 627370

This macro will do the work except for the lines between records, 3 lines will remain. The main point is that the record should start with "Image Name" (the check is case-insensitive). You can adjust it later to match the requirements.

Sub ReorderImageRecords()
Dim cnt As Long, curidx As Long

For i = 1 To ActiveSheet.UsedRange.Rows.Count
 cnt = 0
 If Left(LCase(Cells(i, 1)), 10) = "image name" Then
   Cells(i + 1, 1).EntireRow.Delete
   Cells(i + 1, 1).EntireRow.Delete
   curidx = i
   Cells(curidx + 1, 1) = "Annotation"
   Cells(curidx + 1, 2) = "Comment"
   Cells(curidx + 1, 3) = "Value"
   Cells(curidx + 1, 4) = "Unit"
   While Not IsEmpty(Cells(curidx + cnt + 2, 2))
     cnt = cnt + 1
     Cells(curidx + cnt + 1, 2) = Cells(curidx + cnt + 2, 3)
     Cells(curidx + cnt + 2, 2).EntireRow.Delete
   Wend
   i = i + cnt + 1
 End If
Next i

End Sub

UPDATE

And here is an optimized version without curidx and with the code to remove extra lines in between image records:

Sub ReorderImageRecords()
Dim cnt As Long, i As Long

For i = 1 To ActiveSheet.UsedRange.Rows.Count
 cnt = 0
 If i > 1 Then ' If it is not the 1st row
   If Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then
     Cells(i - 1, 1).EntireRow.Delete ' Delete if the whole preceding row is empty
   End If
   If Application.CountA(Cells(i - 1, 1).EntireRow) = 0 Then
     Cells(i - 1, 1).EntireRow.Delete ' Repeat row removal
   End If
 End If
 If Left(LCase(Cells(i, 1)), 10) = "image name" Then ' We found an image record start
   Cells(i + 1, 1).EntireRow.Delete ' We delete unnecessary blank rows
   Cells(i + 1, 1).EntireRow.Delete ' Repeat removal
   Cells(i + 1, 1) = "Annotation"   ' Insert headers
   Cells(i + 1, 2) = "Comment"
   Cells(i + 1, 3) = "Value"
   Cells(i + 1, 4) = "Unit"
   While Not IsEmpty(Cells(i + cnt + 2, 2)) ' If we are still within one and the same record
     cnt = cnt + 1
     Cells(i + cnt + 1, 2) = Cells(i + cnt + 2, 3) ' Copy comment
     Cells(i + cnt + 2, 2).EntireRow.Delete        ' Remove row with comment
   Wend
   i = i + cnt + 1 ' Increment row index to the current value
 End If
Next i

End Sub

Upvotes: 0

Related Questions