copy cell info to another group of cells

**dalerdd** · 10-10-2012, 04:24 PM

I have been trying to get this portion of a job going.
I have a column A A1 = date - 10/10/2012 -- channel info
A2 = Slot Name
A3 - A?
A? + 1 = Slot Name

I have trying to find Slot Name select the cell above which in this case be A1, format that string to a substring of 10/10/2012 then take the value and paste it between the Slot Name.

I have attached the file.
I know I am missing something within the for Next statement.
The number of empty cells between is random along with the number of Slot Name.

Thanks
Dale
New to forum.

**dalerdd** · 10-10-2012, 04:39 PM

Sub UseArray()
Dim c As Range, LR As String, dateS As String, arr() As String, x, y, e, d As Long 'declare variables


Sheets("PRGGRID").Select
    Columns("A:A").Select
LR = Range("A6555").End(xlUp).Row   'set Lr equal to the last row in column A that contains a value

For Each c In Range("A1:A" & LR).Cells  'loop through cells in column A from row 1 to LR
    'If c.Value <> vbNullString Then 'if the current cell in the loop is not empty then
       ' If Len(x) = 0 Then  'if x is not set to anything then
           ' x = c.Value 'set x to the current cell in the loop's value
       ' Else    'if x is something then
           ' x = x & ";" & c.Value   'reset x to the current value of x followed by ; and then by the current cell in the loop's value
       ' End If  'end if len statement
    'End If  'end if c.value statement
    
        If c.Value <> vbNullString Then 'if the current cell in the loop is not empty then
       If Len(x) = 0 Then
       
       'if x is not set to anything then
           x = c.Value 'set x to the current cell in the loop's value
           ' x = x + 1
       Else    'if x is something then
          x = x & ";" & c.Value
            'x.FormulaR1C1 = "10/1/2012" 'reset x to the current value of x followed by ; and then by the current cell in the loop's value
      End If  'end if len statement
    End If  'end if c.value statement
Next c  'move to next cell in the loop

arr = Split(x, ";") 'set arr (the array) equal to the value of x seperated by the ; character

For y = LBound(arr) To UBound(arr)  'loop through y from the first value in the arr list to the last value
    If arr(y) = "Slot Name" Then
    e = y
    d = y
     Range("A" & e).Select
     Range("A" & d) = Mid(Range("A" & e), 8, 10)
     'ActiveCell.FormulaR1C1 = "What the FWEF@#@#"
    
    'MsgBox "all right"
    MsgBox (arr(y))
    e = e - 1
    d = d + 1
    End If
    If Len(arr(y)) = 0 Then
        ActiveCell = "fill in this"
    End If
        
    'MsgBox arr(y)   'provide message box with the current list item in the arr array based on the number of y
Next y  'move to next y
    
End Sub

**mike7952** · 10-10-2012, 05:19 PM

Give this a try

Sub DateExtract()
 Dim r As Range, i As Long, sdate As String, sslot As String
    
    ReDim a(1 To Cells(Rows.Count, "a").End(xlUp).Row, 1 To 1)
    With CreateObject("VBScript.RegExp")
        .Global = False
        .Pattern = "[\d]+[\/-][\d]+[\/-][\d]+"
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
            If .test(r.Value) Then
                sdate = .Execute(r)(0)
            Else
                sslot = r.Value
            End If
            If Not Len(Trim(sslot)) > 0 Then
                a(r.Row, 1) = sdate
            Else
                a(r.Row, 1) = sslot
            End If
            sslot = ""
        Next
    End With
    Range("b1").Resize(UBound(a), UBound(a, 2)) = a
End Sub