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

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
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

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
856
Micron
M
F
  • Question Question
[VBA Question]: Copy/paste every single quarter - replicate 40 times in a quarter
Replies
1
Views
55
StephenCrump
S
S
  • Question Question
VBA : Reflection Workspace extract all screen/pages
Replies
0
Views
101
Samantha27
S
J
  • Question Question
vba to find specific text in a column and then when found copy all the rows above it
Replies
1
Views
119
mumps
mumps
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
442
Akuini
Akuini

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

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