Copy and Paste and Delete Columns Based on Criteria

**datalogger** · 12-20-2010, 06:23 PM

I need to reformat my data. Right now it look slike this (only 3 rows, but thousands of columns):

A B C D E F
1 mat 1 mat 2 mat 3 mat 4
2 equip 1 equip 2 equip 3 equip 4 equip 5 equip 6
3 equip Info equip Info equip Info equip Info equip Info equip Info

Where row 1 is blank, this data in the column is associated with the preceding "mat#". I need to cut and paste the extra equip # and equip info under the corresponding mat# column and omit the blank columns. The reformatted spreadsheet should look like this:

A B C F
1 mat 1 mat 2 mat 3 mat 4
2 equip 1 equip 2 equip 3 equip 6
3 equip Info equip Info equip Info equip Info
equip 4
equip Info
equip 5
equip Info

See the attached file for better depiction of data. Here is the code I have so far

Code:

Sub FormatFromPivotToANRR()

    Dim c
    For Each c In Range("A1:DPT1").Cells
        If c = "" Then
            c.Select
            ActiveCell.Offset(1, 0).Range("A1:A2").Select
            Selection.Copy
            ActiveCell.Offset(0, -1).Columns("A:A").EntireColumn.Select
            Selection.End(xlDown).Offset(1, 0).Select
            ActiveSheet.Paste
            ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
            Application.CutCopyMode = False
            Selection.Delete Shift:=xlToLeft
            End If
             Next
End Sub

End Code:

Thanks in advance.

**antoka05** · 12-21-2010, 09:01 AM

You could use this code:

Sub FormatFromPivotToANRR()
   Dim lastCol As Integer, c As Integer
   Dim lastRow As Long, destRow As Long

   With ThisWorkbook.ActiveSheet
      lastCol = .Cells.Find("*", SearchOrder:=xlByColumns, _
         SearchDirection:=xlPrevious).Column
      For c = lastCol To 1 Step -1
         If .Cells(1, c) = "" And c > 1 Then
            lastRow = .Cells(Rows.Count, c).End(xlUp).Row
            destRow = .Cells(Rows.Count, c - 1).End(xlUp).Row + 1
            .Cells(2, c).Resize(lastRow - 1).Copy .Cells(destRow, c - 1)
            .Columns(c).Delete
         End If
      Next c
      .Cells.EntireColumn.AutoFit
   End With
End Sub

Regards,
Antonio