Copy Certain Text to Empty Cell

[pdmken]

I am working on a data feed and need to add some text to individual columns. I need to copy part of the contents from column F to column G with all text to the left of word tablet PC. What's to the left maybe manufacturer and model number. Some of the cells don't have the word tablet PC and can be manually entered.

Using Excel 2007

 

[ParamRay]

.
.

Try something like this:

Sub CopyRange()

    Dim rng As Range
    Dim txt As String
    Dim cell As Range
    Dim pos As Byte
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    
    With ActiveSheet
        On Error Resume Next
        Set rng = Intersect(.Columns("F"), .UsedRange)
        On Error GoTo 0
    End With
    
    If Not rng Is Nothing Then
        txt = "tablet pc"   'text to search for
        For Each cell In rng
            pos = InStr(LCase(cell.Value), LCase(txt))
            With cell.Offset(0, 1)
                Select Case pos
                    Case Is = 0: .Value = vbNullString
                    Case Else: .Value = Trim(Left(cell.Value, pos - 1))
                End Select
            End With
        Next cell
    End If

End Sub

 

[pdmken]

.
.

Try something like this:

Sub CopyRange()

    Dim rng As Range
    Dim txt As String
    Dim cell As Range
    Dim pos As Byte
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    
    With ActiveSheet
        On Error Resume Next
        Set rng = Intersect(.Columns("F"), .UsedRange)
        On Error GoTo 0
    End With
    
    If Not rng Is Nothing Then
        txt = "tablet pc"   'text to search for
        For Each cell In rng
            pos = InStr(LCase(cell.Value), LCase(txt))
            With cell.Offset(0, 1)
                Select Case pos
                    Case Is = 0: .Value = vbNullString
                    Case Else: .Value = Trim(Left(cell.Value, pos - 1))
                End Select
            End With
        Next cell
    End If

End Sub

Worked perfectly, thanks

 

[Rick Rothstein]

Here is a shorter macro that should also work for you...

Sub CopyRange()
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, "F").End(xlUp).Row
  Range("G1:G" & LastRow) = Evaluate(Replace("IF(ISNUMBER(SEARCH(""tablet pc"",F1:F#)),TRIM(" & _
                            "LEFT(F1:F#,SEARCH(""tablet pc"",F1:F#)-1)),"""")", "#", LastRow))
End Sub