Consolidating Blank Columns grr

[ellison]

We are using an excel file to tidy up data and the file is getting bigger and bigger (understatement!)
To help consolidate the data, we would like to copy it into a fresh sheet & keep all of the rows, but only keep columns of data which contain any info
Also each Column has a header in the first row, which has got us totally scratching our heads about how to do this without some fairly precarious copy and pasting…!
Here is some sample data, hope this makes this a bit clearer

Line ID	Colour1	Colour2	Colour3	Colour4	Colour5
Data1	white		yellow
Data2
Data3	grey		red
Data4	purple				white

So in this instance, neither of the columns on Colour 2 nor Colour 4 have any entries, so when we copy it over, we'd like to see something like this:
(Oops, just to confirm: despite the fact that "Data2" has no info on that "row", we would still like to keep Data2 in the results.)

LineID	Colour1	Colour3	Colour5
Data1	white	yellow
Data2
Data3	grey	red
Data4	purple		white

And just to confirm, I have tried using the skip blank feature, but it doesn't seem to want to play ball - especially with me!

 

[MickG]

Try this on your data sheet for results on sheet2

Sub nCopy()
Dim Ray As Variant, nRay As Variant, nStr As String, Ac As Long, Sp As Variant
 Ray = ActiveSheet.Cells(1).CurrentRegion
 For Ac = 1 To UBound(Ray, 2)
    If Application.CountA(Cells(2, Ac).Resize(UBound(Ray, 1) - 1)) > 0 Then
        nStr = nStr & IIf(nStr = "", Ac, "," & Ac)
    End If
 Next Ac
  Sp = Split(nStr, ",")
  nRay = Application.Index(Ray, Evaluate("row(" & 1 & ":" & UBound(Ray) & " )"), Sp)

  With Sheets("Sheet2")
      .UsedRange.Clear
      .Range("A1").Resize(UBound(Ray, 1), UBound(Sp) + 1) = nRay
  End With
End Sub

 

[jmacleary]

Hi there. Once you have copied the data into a new sheet, run this macro on that new sheet:

Sub remover()
    lastcol = ActiveSheet.UsedRange.Columns.Count
    For tstcol = lastcol To 1 Step -1
        If Application.WorksheetFunction.CountA(Cells(1, tstcol)) = 1 And Application.WorksheetFunction.CountA(Columns(tstcol)) = 1 Then
            ActiveSheet.Columns(tstcol).EntireColumn.Delete

        End If
    Next
End Sub

It will remove any columns that have something in row 1 but nowhere else.

 

[Akuini]

Just another way:

Sub a1116434a()
Dim i As Long
Application.ScreenUpdating = False
Cells.Copy Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Activate
For i = Cells(1, Columns.count).End(xlToLeft).Column To 1 Step -1
    If Columns(i).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row = 1 Then Columns(i).Delete
Next
Application.ScreenUpdating = True
End Sub

 

[ellison]

Works beautifully ………… HUGE thanks to you both!!!!