Search for non value and move contents to a specific cell

[fddekker]

Thanks in advance for any suggestions!
<o> </o>
I have information in column B which is a list of account codes and names, with a sub-total name below the names, eg.
106432 Salaries (B3)
106772 Benefits (B4)
106882 Leave entitlements (B5)
106999 Other entitlements (B6)
Salaries & Benefits (B7)
107554 General contractors (B8)
107662 Medical contractors (B9)
107880 Consultants (B10)
Professional services (B11)
<o> </o>
I would like to move the sub-total name to column A (currently blank) and populate cells A3:A6 with ‘Salaries & Benefits’ and A8:A10 with ‘Professional services' in this example. This would allow rows 7 and 11 to be empty and ready for deletion.
<o> </o>
How do I do a search on the first cell that does NOT start with a number and then cut the cell contents and move it to the left of the first cell in that range?
<o> </o>
<o> </o>

 

[Trebor76]

Hi feddekker,

The following macro will do the job - as long as the starting cell selected via the inputbox is not in Column A (if this does happen, the user will be informed of such and the process will then be terminated):

Sub Macro2()

Dim rngCellStart As Range
Dim strColAdj, strColActive, strCellText As String
Dim lngCellStart, lngCellEnd As Long

    On Error Resume Next
        Application.DisplayAlerts = False
            Set rngCellStart = Application.InputBox(Prompt:= _
                "Click on the cell where the dataset commences eg B3:", _
                    Title:="SPECIFY RANGE", Type:=8)
    On Error GoTo 0
        Application.DisplayAlerts = True

        If rngCellStart Is Nothing Then
            Exit Sub
        End If
             
strColActive = Mid(rngCellStart.Address, 2, _
               (InStr(2, ActiveCell.Address, "$")) - 2)
               
    If StrConv(strColActive, vbUpperCase) = "A" Then
        MsgBox "Column A is not applicable as there needs to be a blank " & _
        "column to the left of the dataset.", vbExclamation, "Dataset Selector Editor"
    Exit Sub
    End If
               
strColAdj = Mid(rngCellStart.Offset(0, -1).Address, 2, _
            (InStr(2, ActiveCell.Address, "$")) - 2)
               
lngCellStart = rngCellStart.Row

Range(strColAdj & lngCellStart).Select

    Do Until IsEmpty(ActiveCell.Offset(0, 1)) = True
    
        Do Until Not IsNumeric(Left(ActiveCell.Offset(0, 1), 1))
            ActiveCell.Offset(1, 0).Select
        Loop
        
        strCellText = Left(ActiveCell.Offset(0, 1), InStr(ActiveCell.Offset(0, 1), "(") - 2)
        lngCellEnd = ActiveCell.Row - 1
        
        Range(strColAdj & lngCellStart).Value = strCellText
        Range(strColAdj & lngCellStart).Copy _
            Range(strColAdj & lngCellStart + 1 & ":" & strColAdj & lngCellEnd)
        
        lngCellStart = lngCellEnd + 2
        
        Range(strColAdj & lngCellStart).Select
        
    Loop
        
End Sub

HTH

Robert

 

[jindon]

try

Sub test()
With Range("b3", Range("b" & Rows.Count).End(xlUp)).Offset(,-1)
    .Formula = "=if(isnumber(--left(b3,1)),if(isnumber(--left(b4,1)),a4,b4),"""")"
    .Value = .Value
End With
End Sub

 

[fddekker]

Great ... works perfectly! Thanks guys.