VBA CODE to auto drag

[Jan Kalop]

Looking for VBA CODE to auto drag and fill numbers and alphabet, but with alphabet beyond 26 characters .....for sample from A to AAAA or even further

 

[Yongle]

Please clarify

Is this what you want ?
string "A1" Drag down = "A2" , "A3", "A4" ...
string "A1" Drag across "B1", "B2", "B3" .... "AA1" .. "ZZ1" ..."AAA1" ...."ZZZ1"

 

[Jan Kalop]

Please clarify

Is this what you want ?
string "A1" Drag down = "A2" , "A3", "A4" ...
string "A1" Drag across "B1", "B2", "B3" .... "AA1" .. "ZZ1" ..."AAA1" ...."ZZZ1"

Can be like that as well, but generally I was looking for "1","2","3" and "A", "B","ZZZ", in all directions

 

[Yongle]

This is my initial stab at your problem
- it is not very elegant but it appears to do what you requested
- it handles either ALL numbers or ALL alpha but alphanumeric not considered
- when I get some time I will look at it again (probably next week)
- in the meantime, please test it and see if it does broadly what you want and let me know

Test it like this
Place the code in a module
In cell B2 enter value AA
In cell C2 enter formula =DRAG(B2) and then drag the formula across
In cell B3 enter formula =DRAG(B2) and then drag the formula down
amend the value in B2 to ZZZ
amend the value in B2 to 120

Function Drag(ByVal Previous As Variant) As Variant
    Dim t As Long, mySum As Long
    Select Case VarType(Previous)
        Case 5: Drag = Previous + 1
        Case 8: Drag = GetString(UCase(Previous))
    End Select
End Function

Private Function GetString(Previous As String) As String
    Dim t As Long, pCount As Long, val As Long, myStr As String
    Dim AddOne As Boolean
    Dim arr() As Variant, arr2 As Variant
    pCount = Len(Previous)
    AddOne = True
    ReDim arr(0 To pCount)
    ReDim arr2(0 To pCount)
'convert letters to ascii
    For t = pCount To 1 Step -1
        arr(pCount - t) = Asc(Mid(Previous, t, 1))
    Next t
'add one to value
    For t = 0 To UBound(arr) - 1
        If AddOne Then val = arr(t) + 1 Else val = arr(t)
        AddOne = (val = 91)
        If val = 91 Then val = 65
        arr2(t) = Chr(val)
    Next t
'string values together
    For t = pCount To 0 Step -1
        myStr = myStr & arr2(t)
    Next t
    If Len(Replace(myStr, "A", "")) = 0 Then myStr = "A" & myStr
    GetString = myStr
End Function

 

[Jan Kalop]

This is my initial stab at your problem
- it is not very elegant but it appears to do what you requested
- it handles either ALL numbers or ALL alpha but alphanumeric not considered
- when I get some time I will look at it again (probably next week)
- in the meantime, please test it and see if it does broadly what you want and let me know

Test it like this
Place the code in a module
In cell B2 enter value AA
In cell C2 enter formula =DRAG(B2) and then drag the formula across
In cell B3 enter formula =DRAG(B2) and then drag the formula down
amend the value in B2 to ZZZ
amend the value in B2 to 120

Function Drag(ByVal Previous As Variant) As Variant
    Dim t As Long, mySum As Long
    Select Case VarType(Previous)
        Case 5: Drag = Previous + 1
        Case 8: Drag = GetString(UCase(Previous))
    End Select
End Function

Private Function GetString(Previous As String) As String
    Dim t As Long, pCount As Long, val As Long, myStr As String
    Dim AddOne As Boolean
    Dim arr() As Variant, arr2 As Variant
    pCount = Len(Previous)
    AddOne = True
    ReDim arr(0 To pCount)
    ReDim arr2(0 To pCount)
'convert letters to ascii
    For t = pCount To 1 Step -1
        arr(pCount - t) = Asc(Mid(Previous, t, 1))
    Next t
'add one to value
    For t = 0 To UBound(arr) - 1
        If AddOne Then val = arr(t) + 1 Else val = arr(t)
        AddOne = (val = 91)
        If val = 91 Then val = 65
        arr2(t) = Chr(val)
    Next t
'string values together
    For t = pCount To 0 Step -1
        myStr = myStr & arr2(t)
    Next t
    If Len(Replace(myStr, "A", "")) = 0 Then myStr = "A" & myStr
    GetString = myStr
End Function

Yes it's pretty nifty and simple in use, the only difficulty is probably entering the formula, but you can get used to it, because it is very esy to remember. Thanks for your help and this is exactly what i was looking for. As you mention that you are going to spend some time to make some improvment, please let me know if you get with something better. Many thanks...

 

[Yongle]

How about a simple procedure, triggered by a shortcut ...asking you to ..
... click on base cell
(which would auto-create the formula =DRAG(BaseCellAddress)
... click on first cell
(which would place the formula in that cell)

Sub DragFormula()
    Dim c As Range, f As Range
    Set c = Application.InputBox("Select base cell and click OK", "", , , , , , 8)
    Set f = Application.InputBox("Select 1st cell and click OK", "", , , , , , 8)
    f.Formula = "=Drag(" & c.Address(0, 0) & ")"
End Sub

Then drag down or across as required

 

[Jan Kalop]

How about a simple procedure, triggered by a shortcut ...asking you to ..
... click on base cell
(which would auto-create the formula =DRAG(BaseCellAddress)
... click on first cell
(which would place the formula in that cell)

Sub DragFormula()
    Dim c As Range, f As Range
    Set c = Application.InputBox("Select base cell and click OK", "", , , , , , 8)
    Set f = Application.InputBox("Select 1st cell and click OK", "", , , , , , 8)
    f.Formula = "=Drag(" & c.Address(0, 0) & ")"
End Sub

Then drag down or across as required

sorry, but i am lost, how this supposed to work? ......it is a separate code or suppose to work with the other

 

[Yongle]

How would you like it to work ?
Here is one way

With shortcut {CTRL} q
Create the shortcut like this

{ALT}{F8} to list macros
Select DragFormula
Cliclk on Options
type q in the box to right of CTRL+
and click OK

Run with {CTRL} q

 

[Jan Kalop]

Run with {CTRL} q
[/QUOTE]

fantastic.....works like a charm.....thank you very much. Again I learned something new