Copy Names That Begin with A-L

[j6sander]

Hello, I have googled the snot out of this and can't come up with an answer. I need a code that will search through B5:B40 on Sheet1, sort alphabetically, and then copy only the names that start with the letters A-L and past them into Sheet2 starting at B5. Then copy all the names from Sheet1 that start with M-Z and past them into Sheet3 starting at B5 again. Please help.

[mike7952]

Try this

Sub abcd()
 Dim TheNames As Range, cell As Range
 Dim AL, MZ
 Dim TempSort As String
 Dim NoExchanges As Integer
 
 
 Set TheNames = Range("b5:b40")
 
    ReDim AL(1 To 1)
    ReDim MZ(1 To 1)
    For Each cell In TheNames
       If Left(cell, 1) <= "L" Then
           AL(UBound(AL)) = cell
           ReDim Preserve AL(1 To UBound(AL) + 1)
       End If
       If Left(cell, 1) >= "M" Then
           MZ(UBound(MZ)) = cell
           ReDim Preserve MZ(1 To UBound(MZ) + 1)
       End If
    Next
    ReDim Preserve AL(1 To UBound(AL) - 1)
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 1 To UBound(AL) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If AL(i) > AL(i + 1) Then
                NoExchanges = False
                TempSort = AL(i)
                AL(i) = AL(i + 1)
                AL(i + 1) = TempSort
            End If
        Next i
    Loop While Not (NoExchanges)
    
    ReDim Preserve MZ(1 To UBound(MZ) - 1)
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 1 To UBound(MZ) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If MZ(i) > MZ(i + 1) Then
                NoExchanges = False
                TempSort = MZ(i)
                MZ(i) = MZ(i + 1)
                MZ(i + 1) = TempSort
            End If
        Next
    Loop While Not (NoExchanges)
    
    Worksheets("Sheet2").Range("b5").Resize(UBound(AL)) = WorksheetFunction.Transpose(AL)
    Worksheets("Sheet3").Range("b5").Resize(UBound(MZ)) = WorksheetFunction.Transpose(MZ)
End Sub

[rvasquez]

Hello there,

The following code should work for you:

Dim c As Range, LR As String, x As Long, y As Long
x = 5   'set x equal to 5, will be used to reference the starting paste to row for sheet2
y = 5   'set y equal to 5, will be used to reference the starting paste to row for sheet3
With Sheets("Sheet1")
    'LR = .Range("A6555").End(xlUp).Row  'set LR equal to the last row in column A on sheet1
        For Each c In .Range("B5:B40").Cells    'loop through cell in column B starting at row 5 and ending at row 40
            Select Case Left(c.Value, 1)    'if the first letter of the current cell in the loop is...
                Case "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L" 'any of these letters then...
                    Sheets("Sheet2").Cells(x, 2) = c.Value  'set the cell in worksheet sheet2 row x
                                                            '(defined as starting at 5 and will increment 1
                                                            'every time a value is added to sheet2) column B (aka 2)
                        x = x + 1   'increment x by one so that you don't copy the value over the existing values
                Case "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z"   'if the first letter of the current cell in the loop is...
                    Sheets("Sheet3").Cells(y, 2) = c.Value 'set the cell in worksheet sheet3 row y
                                                            '(defined as starting at 5 and will increment 1
                                                            'every time a value is added to sheet3) column B (aka 2)
                        y = y + 1   'increment y by one so that you don't copy the value over the existing values
            End Select
        Next c  'move to next cell in the loop
End With

To insert this code into your workbook
1. Press Alt+F8
2. Clear the macro name field and then type DistributeVal
3. Select the create option
4. In between the Sub DistributeVal() and End Sub copy and paste the above code. Anything that appears in green is a comment meant to help you understand.
5. Exit out of Visual Basic
6. Press Alt+F8
7. Select the DistributeVal macro
8. Select the Run option

Let me know if this works for you.

Thanks!

[Kyle123]

Another way based on there always being an entry for M

Sub Copy()

Dim rng, rng1, rng2
rng = Application.Transpose(Sheet1.Range("B5:B40").Value)
With CreateObject("System.Collections.ArrayList")
    For x = LBound(rng) To UBound(rng)
        .Add rng(x)
    Next x
    .Sort
    rng = Join(.toArray, vbCr)
    rng1 = Split(Left(rng, InStr(1, UCase(rng), vbCr & "M")), vbCr)
    rng2 = Split(Right(rng, Len(rng) - Len(Join(rng1))), vbCr)
    Sheet2.Cells(5, 2).Resize(UBound(rng1) + 1).Value = Application.Transpose(rng1)
    Sheet3.Cells(5, 2).Resize(UBound(rng2) + 1).Value = Application.Transpose(rng2)
End With

End Sub

[watersev]

option, assuming names mean words

Sub test()

Application.ScreenUpdating = 0

With Range("b4:b40")
    
    .Sort key1:=Range("b4"), header:=xlYes
    .AutoFilter 1, "<M"
    .Offset(1).Copy Sheets(2).Range("b5")
    .AutoFilter 1, ">M"
    .Offset(1).Copy Sheets(3).Range("b5")
    .AutoFilter
    
End With

Application.ScreenUpdating = 1

End Sub

[Kyle123]

Version 2 without the need for a name beginning with M

Sub Copy()

Dim rng, rng1, rng2
Dim Max As Long, x As Long
rng = Application.Transpose(Sheet1.Range("B5:B20").Value)
Max = Asc("a")

With CreateObject("System.Collections.ArrayList")
    For x = LBound(rng) To UBound(rng)
        .Add rng(x)
        If Asc(LCase(rng(x))) > Max And Asc(LCase(rng(x))) <= 109 Then Max = Asc(LCase(rng(x)))
    Next x
    .Sort
    rng = Join(.toArray, vbCr)
    rng1 = Split(Left(rng, InStr(1, LCase(rng), vbCr & Chr(Max))), vbCr)
    rng2 = Split(Right(rng, Len(rng) - Len(Join(rng1))), vbCr)
    Sheet2.Cells(5, 2).Resize(UBound(rng1) + 1).Value = Application.Transpose(rng1)
    Sheet3.Cells(5, 2).Resize(UBound(rng2) + 1).Value = Application.Transpose(rng2)
End With

End Sub

[AB33]

Hi Kyle!
I tried to use your code on Watersev's sheet, but I have got an error on this line

rng = Application.Transpose(Sheet1.Range("B4:B30").Value)

[Kyle123]

At a guess (I can't open watersev's document on my mac) he's not using an English Language version of Excel. Try changing:
Sheet1 to Sheets(1)
Sheet2 to Sheets(2)
Sheet3 to Sheets(3)

[john456852]

on mine watersev's worked

[mike7952]

@John456852

Its not that his code dosent work, its that Kyle's code wasnt working on watersev's workbook. Kyle's code uses Sheet code names, and in waterserv's workbook sheet code names are ????1

[john456852]

all i see is :

Sub test()

Application.ScreenUpdating = 0

With Range("b4:b40")
    
    .Sort key1:=Range("b4"), header:=xlYes
    .AutoFilter 1, "<M"
    .Offset(1).Copy Sheets(2).Range("b5")
    .AutoFilter 1, ">M"
    .Offset(1).Copy Sheets(3).Range("b5")
    .AutoFilter
    
End With

Application.ScreenUpdating = 1

End Sub

[Kyle123]

Thanks Mike

John, there are several ways of referencing sheets, my code will work fine on English versions of Excel, since Watersev doesn't use an English version of Excel his sheet object names (down the left hand side of the VBA IDE in the object Explorer) are not Sheet1 Sheet2 Sheet3 etc, rather they will be named in the language of the Excel installation that he is using so the objects that I reference do not exist.

You'll see that watersev uses an alternative style of referencing sheets Sheets(2), this uses the sheets collection to refer to a sheet and works irrespective of sheet name.

When I post code, I generally use the vba name of the sheet (as opposed to sheets("sheetname") or Sheets(1) which both refer to the sheets collection) since it will work after changing the sheet name property and remains constant regardless of sheet inserts and deletions, referring to the collection will not.

My suggestion above as to change the type of referencing in my code to that of the style used by watersev to remove the dependance on English Sheet names whilst using watersev's wb.

Does that clear it up any?

[john456852]

Yes, it does
so, u mean that he has sheets that aren't named"sheet1,sheet2,etc."

[mike7952]

@John

heres kyle's code with sheet index instead of code names

Sub Copy()

Dim rng, rng1, rng2
Dim Max As Long, x As Long
rng = Application.Transpose(Sheets(1).Range("B5:B20").Value)
Max = Asc("a")

With CreateObject("System.Collections.ArrayList")
    For x = LBound(rng) To UBound(rng)
        .Add rng(x)
        If Asc(LCase(rng(x))) > Max And Asc(LCase(rng(x))) <= 109 Then Max = Asc(LCase(rng(x)))
    Next x
    .Sort
    rng = Join(.toArray, vbCr)
    rng1 = Split(Left(rng, InStr(1, LCase(rng), vbCr & Chr(Max))), vbCr)
    rng2 = Split(Right(rng, Len(rng) - Len(Join(rng1))), vbCr)
    Sheets(2).Cells(5, 2).Resize(UBound(rng1) + 1).Value = Application.Transpose(rng1)
    Sheets(3).Cells(5, 2).Resize(UBound(rng2) + 1).Value = Application.Transpose(rng2)
End With

End Sub

[john456852]

ok. thx .

[Marcol]

Hmm?

As a matter of interest this can be done without VBa, might be handy when macros are not allowed, or for proud mac owners running a version that doesn't support VBa.

See this workbook sorting text with formulae should be of interest to most.