VBA - Loop Each header to get non blank cells and paste result

Hi,

pls try

Sub macro()
Sheets("Sheet1").Activate
Set Rng = Range(Range("A1"), Cells(1, Columns.Count).End(xlToLeft))
Rng.Copy
Sheets.Add after:=Sheets("Sheet1")
Set sh = ActiveSheet
sh.Range("A1").PasteSpecial Transpose:=True
For Each c In Rng ' not counting header
    sh.Cells(c.Column, 2) = WorksheetFunction.CountA(c.EntireColumn) - 1
Next
End Sub

Select allOpen in new window

Regards

Hi - This works perfectly fine. Just need 1 tweak though. In sheet2, how can i start the data from 2nd row onwards?

Apologies again:

Worksheets(1).Activate
Set Rng = Range(Range("A1"), Cells(1, Columns.Count).End(xlToLeft))
Rng.Copy
Sheets.Add after:=Worksheets(1)
Set sh = ActiveSheet
sh.Range("A2").PasteSpecial Transpose:=True
For Each c In Rng ' not counting header
    sh.Cells(c.Column + 1, 2) = WorksheetFunction.CountA(c.EntireColumn) - 1
Next

I changed the sheet1 to worksheets(1) as the name of the sheet will change from file to file. but i get class error.

Perfect 10

You may also give it a try...

Sub CountDataInColumns()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lc As Long, c As Long, r As Long
Set ws1 = Sheets("Sheet1")

On Error Resume Next
Set ws2 = Sheets("ValueCount")
ws2.Cells.Clear
On Error GoTo 0

If ws2 Is Nothing Then
    Set ws2 = Sheets.Add(after:=ws1)
    ws2.Name = "ValueCount"
End If

lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
r = 2
For c = 1 To lc
   ws2.Cells(r, 1) = ws1.Cells(1, c)
   ws2.Cells(r, 2) = Application.CountA(ws1.Columns(c))
   r = r + 1
Next c
End Sub

Select allOpen in new window