Populate headers in elegant approach

[YasserKhalil]

Hello everyone

I have the following code that populates headers to row 1 as headers and this works well

Code: Select all

Sub Test()
    Dim i As Long, c As Long, m As Long
    
    Const colYasser As Long = 7
    Const colKhalil As Long = 10
    
    ReDim a(1 To 1000)
    
    c = 1
    a(c) = "ID"
    
    For m = 1 To colYasser
        c = c + 1
        a(c) = "Yasser " & m
    Next m
    
    c = c + 1
    a(c) = "Age"
    
    c = c + 1
    a(c) = "Gender"
    
    For m = 1 To colKhalil
        c = c + 1
        a(c) = "Khalil " & m
    Next m
    
    Range("A1").Resize(, c).Value = a
End Sub

In fact this is sample of the original required headers as original will extend to column DN (so large header I know)
and there are a lot of headers that will be repeated with fixed numbers as shown in the code

Is there more elegant way to populate the headers ..? I thought of using public procedure and pass boolean value if the header is of one column and True if I intend to use loops and also pass the required string (text) .. but I don't know how to keep the c variable which represents the columns progress

Any help please

[YasserKhalil]

That's my try till now but I think not that elegant approach

Code: Select all

Public a As Variant
Public cnt As Long
Const colYasser As Long = 7
Const colKhalil As Long = 10

Sub Test()
    ReDim a(1 To 1000): cnt = 0
    
    AddHeader False, "ID"
    AddHeader True, "Yasser ", colYasser
    AddHeader False, "Age"
    AddHeader False, "Gender"
    AddHeader True, "Khalil ", colKhalil
    
    Range("A1").Resize(, cnt).Value = a
End Sub

Sub AddHeader(b As Boolean, s As String, Optional x As Long)
    Dim m As Long
    
    If b Then
        For m = 1 To x
            cnt = cnt + 1
            a(cnt) = s & m
        Next m
    Else
        cnt = cnt + 1
        a(cnt) = s
    End If
End Sub

** Another point sometimes the needed header has the number within the text .. example:
needed headers like that "Header.1.Main" and the next would be "Header.2.Main" and so on .. I can't handle this point

[Doc.AElstein]

Hi Yasser

I like to use Evaluate Range techniques for these sort of things...

Code: Select all

Sub DoEvaluteRangeHead()
'Range("C2").Value = "=" & """Yasser """ & " & " & """.""" & " & " & "Column(B:B) - 0": Debug.Print "=" & """Yasser """ & " & " & """.""" & " & " & "Column(B:B) - 0"
'Dim strEval As String
' Let strEval = "=" & """Yasser """ & " & " & """.""" & " & " & "Column(B:H) - 1": Debug.Print strEval
' Range("B3:H3").Value = Evaluate(strEval)

Range("B3:H3").Value = Evaluate("=" & """Yasser """ & " & " & """.""" & " & " & "Column(B:H) - 1")
End Sub

Yasser .JPG

Alan

[YasserKhalil]

Thanks a lot Mr. Alan
The idea of not using Evaluate or arrays or even cells .. The idea is that the columns will be dynamic according to the inputs and that is the main problem in fact. Review the code to discover the required (the codes are working) but I am searching for more elegant approach

[Doc.AElstein]

Best I can think of is to make my attempt dynamic

Code: Select all

Sub CallAddheader()
 Call AddHeader(1, "B", "H", "Yasser .")
End Sub
Sub AddHeader(ByVal ofst As Long, ByVal Clm1 As String, ByVal Clm2 As String, ByVal Head As String)
Range("" & Clm1 & "4:" & Clm2 & "4").Value = Evaluate("=" & """" & Head & """" & " & " & "Column(" & Clm1 & ":" & Clm2 & ") - " & ofst & "")
End Sub

Sub CallAddheader2()
 Call AddHeader2(1, "2", "8", "Yasser .")
End Sub
Sub AddHeader2(ByVal ofst As Long, ByVal Clm1 As Long, ByVal Clm2 As Long, ByVal Head As String)
Range("" & CL(Clm1) & "5:" & CL(Clm2) & "5").Value = Evaluate("=" & """" & Head & """" & " & " & "Column(" & CL(Clm1) & ":" & CL(Clm2) & ") - " & ofst & "")
End Sub
























' Column letter  http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop      For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
    Do
     Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
     Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
    Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function

Yasser 2.JPG

( Don't forget to copy the Function, Function CL(ByVal lclm As Long) As String )

I can't think of anything more elegant.

Alan
_.______________________________________-

Edit. Just for completeness, if you don't want to use that extra function

Code: Select all

Sub CallAddheader3()
 Call AddHeader3(1, "2", "8", "Yasser .")
End Sub
Sub AddHeader3(ByVal ofst As Long, ByVal Clm1 As Long, ByVal Clm2 As Long, ByVal Head As String)
Range("" & Split(Cells(1, Clm1).Address, "$")(1) & "6:" & Split(Cells(1, Clm2).Address, "$")(1) & "6").Value = Evaluate("=" & """" & Head & """" & " & " & "Column(" & Split(Cells(1, Clm1).Address, "$")(1) & ":" & Split(Cells(1, Clm2).Address, "$")(1) & ") - " & ofst & "")
End Sub

[YasserKhalil]

Thanks a lot. In fact I need the columns not to be implemented hard-coded as it is supposed I don't know exactly the column number ... I have used constants for the fields colYasser and colKhalil as examples and this will be changed to suit the case ..
Regards

[Doc.AElstein]

I need the columns not to be implemented hard-coded as it is supposed I don't know exactly the column number ... I have used constants for the fields colYasser and colKhalil as examples and this will be changed to suit the case ..
Regards

I am not hard coding in my last examples. I am using the variables Clm1 and Clm2 for the columns
That is the point. Sub AddHeader and Sub AddHeader2 do not hard code the columns
I am using "B" and "H" or 2 and 8 just as examples in the example Calling macros

[YasserKhalil]

Yes I see Mr. Alan
But I need not to specify the columns by names nor numbers. Just let it be done through variable as cnt variable I used in Post #2
Thanks any way for great help

[Doc.AElstein]

I am not specifying columns by names or numbers.
I am specifying columns by variables.

But I think I understand you now. I understand what you want
I think that approximately my variable Clm1 would be approximately like your variasbles
colYasser
or
colKhalil

my Clm2 variable could be regarded as approximately your variables
colYasser + cnt
or
colKhalil + cnt

If I developed my attempt to do what your macros are in post #2, then it would not be much more elegant. It would be just slightly shorter.
Each of your loops would be replaced with one code line similar to those i have shown. that is typical with Evaluate range techniques. Generally using Evaluate Range rather than looping is more elegant. That was the main point I was trying to get across.

Because you are looping within VBA , and then pasting out all in one go, your approach is quite good. Mine would not be much better. It would mean you did not loop. But you would paste out 2-4 times. So the improvement is minimal.

I could do something clever putting a final long string into the clipboard and pasting it out in one go. But that would not be particularly elegant

[HansV]

How about this?

Code: Select all

Public a As Variant
Public cnt As Long

Sub Test()
    Const colYasser As Long = 7
    Const colKhalil As Long = 10
    Const colHeaderMain = 15
    ReDim a(1 To 1000)

    AddHeader "ID"
    AddHeader "Yasser @", colYasser
    AddHeader "Age"
    AddHeader "Gender"
    AddHeader "Khalil @", colKhalil
    AddHeader "Header.@.Main", colHeaderMain

    Range("A1").Resize(, cnt).Value = a
End Sub

Sub AddHeader(s As String, Optional x As Long = 1)
    Dim m As Long
    For m = 1 To x
        cnt = cnt + 1
        a(cnt) = Replace(s, "@", m)
    Next m
End Sub

[YasserKhalil]

Thanks a lot Mr. Hans
In fact, that is wonderful and that is easier for me to adapt any number of headers now
Thank you very much for awesome help.

[Doc.AElstein]

Here is a combination of all our ideas….( It looks a little less un elegant in the code window without the extra line breaks added by the forum software )

Code: Select all

' http://www.eileenslounge.com/viewtopic.php?f=30&t=33919&p=262844#p262849
Option Explicit
Dim Cnt As Long
Sub YassersHed3()
 Let Cnt = 1
 Const colYasser As Long = 7
 Const colKhalil As Long = 10

 Call AddHeder("ID")
 Call AddHeder("Yasser @", colYasser)
 Call AddHeder("Age")
 Call AddHeder("Gender")
 Call AddHeder("Khalil .@", colKhalil)
End Sub

Sub AddHeder(Hed As String, Optional Clms As Long = 1)
 Let Range("" & Split(Cells(1, Cnt).Address, "$")(1) & "1:" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & "1").Value = Evaluate("=If({1},SUBSTITUTE(" & """" & Hed & """" & ",""@"",COLUMN(" & Split(Cells(1, Cnt).Address, "$")(1) & ":" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & ") - " & Cnt - 1 & "))")
 Let Cnt = Cnt + (Clms - 1) + 1
End Sub



'________________________________________________________________________________________________________________________________________________________________________________________________________________________________________




















































'Dim strEval As String
' Let strEval = "=If({1},SUBSTITUTE(" & """" & Hed & """" & ",""@"",COLUMN(C:D)))": Debug.Print strEval
' Let strEval = "=If({1},SUBSTITUTE(" & """" & Hed & """" & ",""@"",COLUMN(" & Split(Cells(1, Cnt).Address, "$")(1) & ":" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & ") - " & Cnt - 1 & "))": Debug.Print strEval


'Range("" & Split(Cells(1, Cnt).Address, "$")(1) & "1:" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & "1").Value = Evaluate("=" & """" & Hed & """")
'Range("" & Split(Cells(1, Cnt).Address, "$")(1) & "1:" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & "1").Value = Evaluate("=" & """" & Hed & """" & " & " & "Column(" & Split(Cells(1, Cnt).Address, "$")(1) & ":" & Split(Cells(1, (Cnt + (Clms - 1))).Address, "$")(1) & ") - " & Cnt - 1 & "")



'    Dim m As Long
'    For m = 1 To x
'        Cnt = Cnt + 1
'        a(Cnt) = Replace(s, "@", m)
'    Next m
'End Sub




'Sub Mytests()
'Dim Hed As String, strEval As String
' Let Hed = "Khalil @"
' Let strEval = "=If({1},SUBSTITUTE(" & """" & Hed & """" & ",""@"",COLUMN(C:D)))": Debug.Print strEval
' Range("C6:D6").Value = Evaluate(strEval)
' Let Hed = "ID"
' Let strEval = "=If({1},SUBSTITUTE(" & """" & Hed & """" & ",""@"",COLUMN(C:D)))": Debug.Print strEval
' Range("C7:D7").Value = Evaluate(strEval)
'
'End Sub

Yasser 3.JPG

[YasserKhalil]

Thank you very much Mr. Alan for great efforts
Best Regards