Row to column

[tonyradstone]

I have a list of mooring places on the Burgundy canal in France , I wish to move the data from rows to columns . Some entries will have rows missing when there is no data such as the ratings.

So I would like a columns headed Name ,Lat/Long,reference etc and the data moved

Any help please

Sample file attached

[alansidman]

Try this:

Option Explicit

Sub Moorings()
    Dim w1 As Worksheet
    Dim w2 As Worksheet
    Set w1 = Sheets("Sheet1")
    Set w2 = Sheets("Sheet2")
    Dim lr As Long
    lr = w1.Range("A" & Rows.Count).End(xlUp).Row
    Dim a As Long, b As Long, c As Long, d As Long, e As Long
    Dim f As Long, g As Long, h As Long, k As Long, j As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    For i = 1 To lr
    a = w2.Range("A" & Rows.Count).End(xlUp).Row
    b = w2.Range("B" & Rows.Count).End(xlUp).Row
    c = w2.Range("C" & Rows.Count).End(xlUp).Row
    d = w2.Range("D" & Rows.Count).End(xlUp).Row
    e = w2.Range("E" & Rows.Count).End(xlUp).Row
    f = w2.Range("F" & Rows.Count).End(xlUp).Row
    g = w2.Range("G" & Rows.Count).End(xlUp).Row
    h = w2.Range("H" & Rows.Count).End(xlUp).Row
    k = w2.Range("I" & Rows.Count).End(xlUp).Row
    j = w2.Range("J" & Rows.Count).End(xlUp).Row
    
    If Range("A" & i) = "Name:" Then
    Range("A" & i).Offset(0, 1).Copy w2.Range("A" & a + 1)
        ElseIf Range("A" & i) = "Lat/Long:" Then
        Range("A" & i).Offset(0, 1).Copy w2.Range("B" & b + 1)
            ElseIf Range("A" & i) = "Reference:" Then
            Range("A" & i).Offset(0, 1).Copy w2.Range("C" & c + 1)
                ElseIf Range("A" & i) = "Location:" Then
                Range("A" & i).Offset(0, 1).Copy w2.Range("D" & d + 1)
                    ElseIf Range("A" & i) = "Mooring:" Then
                    Range("A" & i).Offset(0, 1).Copy w2.Range("E" & e + 1)
                        ElseIf Range("A" & i) = "Facilities:" Then
                        Range("A" & i).Offset(0, 1).Copy w2.Range("F" & f + 1)
                            ElseIf Range("A" & i) = "Costs:" Then
                            Range("A" & i).Offset(0, 1).Copy w2.Range("G" & g + 1)
                                ElseIf Range("A" & i) = "Amenities:" Then
                                Range("A" & i).Offset(0, 1).Copy w2.Range("H" & h + 1)
                                    ElseIf Range("A" & i) = "Contributors:" Then
                                    Range("A" & i).Offset(0, 1).Copy w2.Range("I" & k + 1)
                                        ElseIf Range("A" & i) = "Last Update:" Then
                                        Range("A" & i).Offset(0, 1).Copy w2.Range("J" & j + 1)
    End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    MsgBox ("completed")

End Sub

A couple of changes I would suggest your your current data. You have used in some cases two cells one above the other for information. ie.B6 and B7. Make sure all the data is in one cell or it will not transfer properly. Put the data from B7 into the end of B6. There are several places that you need to do this.



How to install your new code

1. Copy the Excel VBA code
2. Select the workbook in which you want to store the Excel VBA code
3. Press Alt+F11 to open the Visual Basic Editor
4. Choose Insert > Module
5. Edit > Paste the macro into the module that appeared
6. Close the VBEditor
7. Save your workbook (Excel 2007+ select a macro-enabled file format, like *.xlsm)

To run the Excel VBA code:

1. Press Alt-F8 to open the macro list
2. Select a macro in the list
3. Click the Run button

[AB33]

Another option, but I had to delete empty row 210 for the code to work in lines.

[AB33]

A different code.
The code works by matching the headings in sheet 2 with columns 1 of sheet1, so all you need is to update the headings in row 1 of sheet2 and click the button on sheet1