Move text from one column to another with very specific restrictions.

[Livin404]

Good day, unfortunately I discovered an additional Macro that will be created (PDF doesn't always save to Excel the way we hope).

I hope to have any text in Column D which has met the this criteria: Is six characters long wich can be alpa-numerica, intergers, or all letters. Part of the numbers/letter a "$" can occur. If this occurs in Column D, and E is blank, move that six digit alphanumeric/letter/intergers in to the adjacent blank cell.
I had been helped with the following Macro wihich I think is going in the right direction. Naturally the bit between "Select Case and End Select"

Thank you so much for reading this.

Public Sub MoveLetters()
    Dim cell As Range
        Application.ScreenUpdating = False
        For Each cell In Range("D2D" & Cells(Rows.Count, "D").End(xlUp).Row)
    Select Case cell.Text
       Case "A", "S", "L"
         cell.Offset(0, 1) = cell.Text
         cell.ClearContents
        Case Else ' what to do if not R,S or L?
          'If nothing, can eliminate these two lines
       End Select
 Next cell
    
    Application.ScreenUpdating = True
    
End Sub

 

[Micron]

This thread isn't a continuation of this one?

Use of Array in Macro

Greetings, I have a Macro which works great, but I need to add the letters "S" and "L". I'm pretty sure it will require an array. Looked for possible example and could not come accross one. The current macro works greaat moving the A, but I need it to move an S and L too if found in Column R...

www.mrexcel.com

Kind of confusing as to how the posted code relates to the new requirement, but I'm thinking you don't need the select anymore?

Public Sub MoveLetters()
Dim cell As Range

Application.ScreenUpdating = False

For Each cell In Range("D2D" & Cells(Rows.Count, "D").End(xlUp).Row)
  If Len(cell.Value) >=6 AND Len(cell.Offset(0, 1)).Value = 0 Then
    cell.Offset(0, 1) = cell.Text
    cell.ClearContents
  End If
Next

Application.ScreenUpdating = True
  
End Sub

That is untested - always try provided code on copies of your sheet/workbook. In Access vba, .Value is the default property so it doesn't have to be written. I don't know if that also applies to Excel. IF you intend to use this code as well as the other one, you will have to give this procedure a unique name.

 

[igold]

I would again caution you not to have your code go back and forth to the sheet in the middle of your loop. It is an extremely inefficient method of coding and will slow you code to a crawl with any large amount of data. Try using an array...

Public Sub MoveLetters()
    
    Dim arr, i As Long
    
    Application.ScreenUpdating = False
    arr = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row)
    For i = 1 To UBound(arr)
        If arr(i, 2) = "" Then
            If Len(arr(i, 1)) = 6 Then
                arr(i, 2) = arr(i, 1)
                arr(i, 1) = ""
            End If
        End If
    Next
    Range("D2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    Application.ScreenUpdating = True
    
End Sub

 

[Livin404]

I would again caution you not to have your code go back and forth to the sheet in the middle of your loop. It is an extremely inefficient method of coding and will slow you code to a crawl with any large amount of data. Try using an array...

Public Sub MoveLetters()
   
    Dim arr, i As Long
   
    Application.ScreenUpdating = False
    arr = Range("D2:E" & Cells(Rows.Count, "D").End(xlUp).Row)
    For i = 1 To UBound(arr)
        If arr(i, 2) = "" Then
            If Len(arr(i, 1)) = 6 Then
                arr(i, 2) = arr(i, 1)
                arr(i, 1) = ""
            End If
        End If
    Next
    Range("D2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    Application.ScreenUpdating = True
   
End Sub

Sorry for the delay. Your code I checked several times, and it worked great. Thank you so much!

 

[igold]

You're welcome. We were happy to help. Thanks for the feedback.