2048 = 2^11 so the numbers below this all have 11 or fewer binary digits. Allow leading zeros so that all have exactly 11 bits. From 0 through 2047, there are 2048*11=22528 binary digits, of which half are 1 bits as every ordered set of binary digits is present. That's 11264 1-bits.

But we want to go only through 2018 and so must subtract out the 1 bits from 2019 through 2047. That's

11111100011  through

11111111111

There are 2047-2018 = 29 of these numbers, so

The high-order 6 bits account for 6*29=174 1-bits.

If the range had included 32 numbers there'd be 32*5/2 1-bits accounted for by the low-order five bits, or 80 of them, but two of these are not in the range: in 00001 and 00010. That makes 78 to be subtracted out on this basis.

So 11264 - (174+78) = 11012 1-bits are in the range asked for.

then

DefDbl A-Z

Dim crlf$

Private Sub Form_Load()

 Form1.Visible = True

 Text1.Text = ""

 crlf = Chr(13) + Chr(10)

 

 For i = 1 To 2018

   b$ = base$(i, 2)

   For j = 1 To Len(b)

     If Mid(b, j, 1) = "1" Then tot = tot + 1

   Next

 Next

 

 Text1.Text = Text1.Text & crlf & tot & " done"

  

End Sub

Function base$(n, b)

  v$ = ""

  n2 = n

  Do

    q = Int(n2 / b)

    d = n2 - q * b

    n2 = q

    v$ = Mid("0123456789abcdefghijklmnopqrstuvwxyz", d + 1, 1) + v$

  Loop Until n2 = 0

  base$ = v$

End Function

 

 

finds 11012 also.