Can some one help to write a piece of vba code

M

msh250

New Member
Joined
Jun 14, 2022
Messages
7
Office Version
  1. 365
Platform
  1. Windows
I am new to VBA and would need help to write a piece of code for the requirements below:
i have a spreadsheet with 1000's of data

From the data in the column “N”, for each line:
  • Copy-paste all the objects starting with “L-“ into a new column named “Location Type”
  • Copy-paste all the objects starting with “T-Special “ into a new column named “Special Requirement”
  • Copy-paste all the objects starting with “S-Echo” and the object “S-Zoom capable” into a new column named “Online Delivery”
  • Copy-paste all the remaining objects into a new column named “Location attributes”
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
Try this. Unsorted labels in column A, new columns in C-F

VBA Code: 
Sub sortem()
'portews 6/14/2022
'https://www.mrexcel.com/board/threads/can-some-one-help-to-write-a-piece-of-vba-code.1207885/

'Add column headers in C-F
Range("C1:F1") = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")

'loop through all of A column starting at row 2
For i = 2 To LastRow("Sheet1", "A")
    'depending on what's in the A cell
    Select Case True
    Case InStr(1, Cells(i, 1), "L-")                        'if it contains "L-"
        Cells(LastRow("Sheet1", "C") + 1, 3) = Cells(i, 1)  'copy to column C
    Case InStr(1, Cells(i, 1), "T-Special")
        Cells(LastRow("Sheet1", "D") + 1, 4) = Cells(i, 1)
    Case InStr(1, Cells(i, 1), "S-Echo") Or InStr(Cells(i, 1), "S-Zoom")
        Cells(LastRow("Sheet1", "E") + 1, 5) = Cells(i, 1)
    Case Else                                               'leftovers
            Cells(LastRow("Sheet1", "F") + 1, 6) = Cells(i, 1) 'go to column F
    End Select
Next

End Sub

Function LastRow(sht As String, ColLetr As String)
'find the last row on a particular sheet and column
LastRow = Sheets(sht).Range(ColLetr & Rows.Count).End(xlUp).Row
End Function
 
Upvote 0
portews said:
Try this. Unsorted labels in column A, new columns in C-F

VBA Code: 
Sub sortem()
'portews 6/14/2022
'https://www.mrexcel.com/board/threads/can-some-one-help-to-write-a-piece-of-vba-code.1207885/

'Add column headers in C-F
Range("C1:F1") = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")

'loop through all of A column starting at row 2
For i = 2 To LastRow("Sheet1", "A")
    'depending on what's in the A cell
    Select Case True
    Case InStr(1, Cells(i, 1), "L-")                        'if it contains "L-"
        Cells(LastRow("Sheet1", "C") + 1, 3) = Cells(i, 1)  'copy to column C
    Case InStr(1, Cells(i, 1), "T-Special")
        Cells(LastRow("Sheet1", "D") + 1, 4) = Cells(i, 1)
    Case InStr(1, Cells(i, 1), "S-Echo") Or InStr(Cells(i, 1), "S-Zoom")
        Cells(LastRow("Sheet1", "E") + 1, 5) = Cells(i, 1)
    Case Else                                               'leftovers
            Cells(LastRow("Sheet1", "F") + 1, 6) = Cells(i, 1) 'go to column F
    End Select
Next

End Sub

Function LastRow(sht As String, ColLetr As String)
'find the last row on a particular sheet and column
LastRow = Sheets(sht).Range(ColLetr & Rows.Count).End(xlUp).Row
End Function
Click to expand...
i run this code but nothing is happening. Not sure why
 
Upvote 0
With data is from N2 down
New 4 columns are in column O to R
VBA Code: 
Option Explicit
Sub Distribute()
Dim lr&, i&, c1&, c2&, c3&, c4&, rng, arr()
lr = Cells(Rows.Count, "N").End(xlUp).Row
rng = Range("N2:N" & lr).Value ' assume data starts from N2
Range("O1:R1").Value = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")
ReDim arr(1 To lr - 1, 1 To 4)
For i = 1 To lr - 1
    If UCase(rng(i, 1)) Like "L-*" Then
        c1 = c1 + 1
        arr(c1, 1) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "T-SPECIAL*" Then
        c2 = c2 + 1
        arr(c2, 2) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "S-ECHO*" Or UCase(rng(i, 1)) Like "S-ZOOM*" Then
        c3 = c3 + 1
        arr(c3, 3) = rng(i, 1)
    Else
        c4 = c4 + 1
        arr(c4, 4) = rng(i, 1)
    End If
Next
Range("O2").Resize(UBound(arr), 4).Value = arr
End Sub

1655259212619.png
 
Upvote 0
Bebo straightened me out. I didn't see the initial column to sort was N.
 
Upvote 0
bebo021999 said:
With data is from N2 down
New 4 columns are in column O to R
VBA Code: 
Option Explicit
Sub Distribute()
Dim lr&, i&, c1&, c2&, c3&, c4&, rng, arr()
lr = Cells(Rows.Count, "N").End(xlUp).Row
rng = Range("N2:N" & lr).Value ' assume data starts from N2
Range("O1:R1").Value = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")
ReDim arr(1 To lr - 1, 1 To 4)
For i = 1 To lr - 1
    If UCase(rng(i, 1)) Like "L-*" Then
        c1 = c1 + 1
        arr(c1, 1) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "T-SPECIAL*" Then
        c2 = c2 + 1
        arr(c2, 2) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "S-ECHO*" Or UCase(rng(i, 1)) Like "S-ZOOM*" Then
        c3 = c3 + 1
        arr(c3, 3) = rng(i, 1)
    Else
        c4 = c4 + 1
        arr(c4, 4) = rng(i, 1)
    End If
Next
Range("O2").Resize(UBound(arr), 4).Value = arr
End Sub

View attachment 67113
Click to expand...
Hi Thanks a lot for this. That worked actually but is it possible to get the data to the corresponding cell. For example in your screenshot N3 is T-Special. Can I able to get that to corresponding cell P3. Likewise all those data to the same row in the respective columns?
 
Upvote 0
portews said:
Try this. Unsorted labels in column A, new columns in C-F

VBA Code: 
Sub sortem()
'portews 6/14/2022
'https://www.mrexcel.com/board/threads/can-some-one-help-to-write-a-piece-of-vba-code.1207885/

'Add column headers in C-F
Range("C1:F1") = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")

'loop through all of A column starting at row 2
For i = 2 To LastRow("Sheet1", "A")
    'depending on what's in the A cell
    Select Case True
    Case InStr(1, Cells(i, 1), "L-")                        'if it contains "L-"
        Cells(LastRow("Sheet1", "C") + 1, 3) = Cells(i, 1)  'copy to column C
    Case InStr(1, Cells(i, 1), "T-Special")
        Cells(LastRow("Sheet1", "D") + 1, 4) = Cells(i, 1)
    Case InStr(1, Cells(i, 1), "S-Echo") Or InStr(Cells(i, 1), "S-Zoom")
        Cells(LastRow("Sheet1", "E") + 1, 5) = Cells(i, 1)
    Case Else                                               'leftovers
            Cells(LastRow("Sheet1", "F") + 1, 6) = Cells(i, 1) 'go to column F
    End Select
Next

End Sub

Function LastRow(sht As String, ColLetr As String)
'find the last row on a particular sheet and column
LastRow = Sheets(sht).Range(ColLetr & Rows.Count).End(xlUp).Row
End Function
Click to expand...
Thanks a lot for this. Really appreciate it
 
Upvote 0
msh250 said:
Hi Thanks a lot for this. That worked actually but is it possible to get the data to the corresponding cell. For example in your screenshot N3 is T-Special. Can I able to get that to corresponding cell P3. Likewise all those data to the same row in the respective columns?
Click to expand...
It should be much more simpler than the old code:
VBA Code: 
Option Explicit
Sub Distribute()
Dim lr&, i&, rng, arr()
lr = Cells(Rows.Count, "N").End(xlUp).Row
rng = Range("N2:N" & lr).Value ' assume data starts from N2
Range("O1:R1").Value = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")
ReDim arr(1 To lr - 1, 1 To 4)
For i = 1 To lr - 1
    If UCase(rng(i, 1)) Like "L-*" Then
        arr(i, 1) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "T-SPECIAL*" Then
        arr(i, 2) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "S-ECHO*" Or UCase(rng(i, 1)) Like "S-ZOOM*" Then
        arr(i, 3) = rng(i, 1)
    Else
        arr(i, 4) = rng(i, 1)
    End If
Next
Range("O2").Resize(UBound(arr), 4).Value = arr
End Sub
 
Upvote 0
bebo021999 said:
It should be much more simpler than the old code:
VBA Code: 
Option Explicit
Sub Distribute()
Dim lr&, i&, rng, arr()
lr = Cells(Rows.Count, "N").End(xlUp).Row
rng = Range("N2:N" & lr).Value ' assume data starts from N2
Range("O1:R1").Value = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")
ReDim arr(1 To lr - 1, 1 To 4)
For i = 1 To lr - 1
    If UCase(rng(i, 1)) Like "L-*" Then
        arr(i, 1) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "T-SPECIAL*" Then
        arr(i, 2) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "S-ECHO*" Or UCase(rng(i, 1)) Like "S-ZOOM*" Then
        arr(i, 3) = rng(i, 1)
    Else
        arr(i, 4) = rng(i, 1)
    End If
Next
Range("O2").Resize(UBound(arr), 4).Value = arr
End Sub
Click to expand...
yayyyy.. That worked. Thankyou sooooo much :)
 
Upvote 0
bebo021999 said:
It should be much more simpler than the old code:
VBA Code: 
Option Explicit
Sub Distribute()
Dim lr&, i&, rng, arr()
lr = Cells(Rows.Count, "N").End(xlUp).Row
rng = Range("N2:N" & lr).Value ' assume data starts from N2
Range("O1:R1").Value = Array("Location Type", "Special Requirement", "Online Delivery", "Location attributes")
ReDim arr(1 To lr - 1, 1 To 4)
For i = 1 To lr - 1
    If UCase(rng(i, 1)) Like "L-*" Then
        arr(i, 1) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "T-SPECIAL*" Then
        arr(i, 2) = rng(i, 1)
    ElseIf UCase(rng(i, 1)) Like "S-ECHO*" Or UCase(rng(i, 1)) Like "S-ZOOM*" Then
        arr(i, 3) = rng(i, 1)
    Else
        arr(i, 4) = rng(i, 1)
    End If
Next
Range("O2").Resize(UBound(arr), 4).Value = arr
End Sub
Click to expand...
can i ask one more doubt. some of the cells in my column N has multiple fields separated by semicolon for example
S-Echo360;S-Echo ;L-CTA Teaching;AV-MEDIUM
can you please help me to split this to the above mentioned columns O1:R1

Some of the cells in Column N has only single values starting with L-, T-Special etc but some cells has multiple values separated by semicolons. In those cases I need to split those values in the cell N at the semicolon and need to split those into the respective columns corresponding to the same row.

can you please help me with this
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Automating copying of columns within same sheet in excel using VBA.
Replies
1
Views
139
MountainFog
M
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
228
Insurance Dave
I
H
  • Question
VBA Code to Copy a defined range from a defined list of Worksheets and paste into another sheet
Replies
3
Views
267
Georgiboy
Georgiboy
P
  • Question
Need VBA to automatically copy paste rows based on dates of current month.
2
Replies
11
Views
222
pk970
P
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
155
kizzie37
K

Forum statistics

Threads
1,214,950
Messages
6,122,428
Members
449,083
Latest member
Ava19

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top