You are here:

Excel/Macro to Split, Sort and Remove Duplicates

Advertisement


Question
QUESTION: Hi Tom,

I request your assistance with regards to few additions in below macro

Sub test()

Application.ScreenUpdating = False

Dim i As Long, j As Long, k As Long, k1 As Long, cnt As Long
Dim rng As Range, fnd As Range
Dim x As Integer
i = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
k = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row

Sheet1.Range("$A$5:$A$" & k).ClearContents

Set rng = Sheet2.Range("A1:A" & i)
Set fnd = rng.Find(What:="*" & "max" & "*", LookIn:=xlValues, MatchCase:=False)

If Not fnd Is Nothing Then
   Sheet2.Range("A" & Sheet1.Range("D2") & ":A" & fnd.Row - 1).Copy
   Sheet1.Range("A5").PasteSpecial xlPasteValues
End If

k = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row

For j = k To 5 Step -1
On Error Resume Next
   If WorksheetFunction.Search("/", Sheet1.Range("a" & j), 1) <= 0 Then
       Rows(j).EntireRow.Delete
   End If
Next

k = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
k1 = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row

Sheet2.Range("$B$1:$C$" & k1).ClearContents

cnt = 1

For j = 5 To k
   Sheet2.Range("C" & cnt) = Mid(Sheet1.Range("a" & j), WorksheetFunction.Search(" ", Sheet1.Range("a" & j), 1) + 2, 2) + 0
   Sheet1.Range("a" & j) = WorksheetFunction.Substitute(Sheet1.Range("a" & j), "   ", " ")
   Sheet2.Range("B" & cnt) = Trim(Mid(Sheet1.Range("a" & j), WorksheetFunction.Search("MR ", Sheet1.Range("a" & j), 1) + 2, 7))
   cnt = cnt + 1
Next

k1 = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row

Sheet2.Range("$B$1:$C$" & k1).RemoveDuplicates Columns:=Array(1, 2), _
       Header:=xlNo

Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub


Raw data is pasted in Column A in Sheet2 with the keyword Max manually entered in the raw data.

What the code does is copy data from specific cells in Sheet2 and paste it in Cell A5 in Sheet1. Then the code sorts and splits 2 specific data from the raw data, removes the duplicates and paste the final data in Column B and C.

A short explanation how the data is copied

In Sheet1 Cell D2 a number will be inserted.
Lets say the number is 10. Macro copies data from Sheet2, Cell 10 in Column A and copy data till cell not containing the keyword max.

Ex - I insert the number as 10 and my keyword max is in cell 144.
When the macro is run it should copy data from cell 10 to cell 143.
Macro should not copy cell containing the keyword max.

This data is pasted in Sheet1, Column A on Cell 5.

Every time when the macro is run it -
Copy data from - As per number entered in Sheet1 Cell D2
Copy data till - Cell number not containing keyword max

Additions I'm looking for -

1) What the current code does is, it will not copy data into sheet1 if the keyword max is not manually entered. I want the macro to prompt a message box stating "Insert Max" if the keyword max is not inserted in raw data in sheet2.

2) The data is pasted in column A cell 5 in sheet1. Columns and cells will change in future. Request you to insert remark in code wherever possible if I want to change the column and cell numbers.

3) I want the final data to be pasted in F2 and G2. Chances are the columns and cells will change in future. I'm not able to figure out how to change the code for this part. I would like you to insert remarks in the code wherever possible if I want to change the 2 columns and cell numbers.

I humbly request you to go through the entire code and make necessary changes wherever required. I will be more than happy If you can simplify the code.

ANSWER: Bimmy,

Here are the modifications I made.  Of course the code is untested so you might need to tweak it.

Sub test()

Application.ScreenUpdating = False

Dim i As Long, j As Long, k As Long, k1 As Long, cnt As Long
Dim rng As Range, fnd As Range
Dim x As Integer
Dim strtrow As Long
Dim strtcol As Long, bCol As String, cCol As String

'Set your locations here; code modified to work with these settings

' originally A5
strtrow = 5
strtcol = "A"

' originally column B
bCol = "B"

' originally column C
cCol = "C"

i = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row

With Sheet1
  .Range(.Cells(strtrow, strtcol), .Cells(k, strtcol)).ClearContents
End With

Set rng = Sheet2.Range("A1:A" & i)
If Application.CountIf(rng, "*max*") = 0 Then
 MsgBox "Please place 'max' to identify what range to copy" & vbNewLine & _
   "Then rerun the macro"
 Exit Sub
End If
Set fnd = rng.Find(What:="*" & "max" & "*", LookIn:=xlValues, MatchCase:=False)

If Not fnd Is Nothing Then
  Sheet2.Range("A" & Sheet1.Range("D2") & ":A" & fnd.Row - 1).Copy
  Sheet1.Cells(strtrow, strtcol).PasteSpecial xlPasteValues
End If

k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row

For j = k To strtrow Step -1
On Error Resume Next
  If WorksheetFunction.Search("/", Sheet1.Range(strtcol & j), 1) <= 0 Then
      Rows(j).EntireRow.Delete
  End If
Next

k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row
k1 = Sheet2.Cells(Rows.Count, bCol).End(xlUp).Row

Sheet2.Range(bCol & "1:" & cCol & k1).ClearContents

cnt = 1

For j = strtrow To k
  Sheet2.Range(cCol & cnt) = Mid(Sheet1.Cells(j, strtcol), WorksheetFunction.Search(" ", Sheet1.Cells(j, strtcol), 1) + 2, 2) + 0
  Sheet1.Range(strtcol & j) = WorksheetFunction.Substitute(Sheet1.Cells(j, strtcol), "   ", " ")
  Sheet2.Range(bCol & cnt) = Trim(Mid(Sheet1.Cells(j, strtcol), WorksheetFunction.Search("MR ", Sheet1.Cells(j, strtcol), 1) + 2, 7))
  cnt = cnt + 1
Next

k1 = Sheet2.Cells(Rows.Count, bCol).End(xlUp).Row

Sheet2.Range(bCol & "1:" & cCol & k1).RemoveDuplicates Columns:=Array(1, 2), _
      Header:=xlNo

Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

--
Regards,
Tom Ogilvy


---------- FOLLOW-UP ----------

QUESTION: Hello Tom,

Thanks for responding.

I'm a beginner as far as coding is concerned. I found the code and tried to tweak it to my requirement but not able to do so.

I just copy pasted your code and tried running it, but getting below error -
Run-time error 13: Type mismatch.

Kindly assist

Answer
Bimmy,

Generally you shouldn't use macros that you can't maintain.  

I did have a variable that was miscast because I changed my mind on what it was to hold and didn't go back an change the type for that variable.  I assume that is what caused the error, but I can't debug your code since I don't have the data.   

Here is the code after I made the change I feel is necessary:

I changed the type for strtcol from Long to String


Sub test()

Application.ScreenUpdating = False

Dim i As Long, j As Long, k As Long, k1 As Long, cnt As Long
Dim rng As Range, fnd As Range
Dim x As Integer
Dim strtrow As Long
Dim strtcol As String, bCol As String, cCol As String

'Set your locations here; code modified to work with these settings

' originally A5
strtrow = 5
strtcol = "A"

' originally column B
bCol = "B"

' originally column C
cCol = "C"

i = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row

With Sheet1
 .Range(.Cells(strtrow, strtcol), .Cells(k, strtcol)).ClearContents
End With

Set rng = Sheet2.Range("A1:A" & i)
If Application.CountIf(rng, "*max*") = 0 Then
MsgBox "Please place 'max' to identify what range to copy" & vbNewLine & _
  "Then rerun the macro"
Exit Sub
End If
Set fnd = rng.Find(What:="*" & "max" & "*", LookIn:=xlValues, MatchCase:=False)
Debug.Print fnd.Address(0, 0, xlA1, True)
If Not fnd Is Nothing Then
 Sheet2.Range("A" & Sheet1.Range("D2") & ":A" & fnd.Row - 1).Copy
 Sheet1.Cells(strtrow, strtcol).PasteSpecial xlPasteValues
End If

k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row
Exit Sub
For j = k To strtrow Step -1
On Error Resume Next
 If WorksheetFunction.Search("/", Sheet1.Range(strtcol & j), 1) <= 0 Then
     Rows(j).EntireRow.Delete
 End If
Next

k = Sheet1.Cells(Rows.Count, strtcol).End(xlUp).Row
k1 = Sheet2.Cells(Rows.Count, bCol).End(xlUp).Row

Sheet2.Range(bCol & "1:" & cCol & k1).ClearContents

cnt = 1

For j = strtrow To k
 Sheet2.Range(cCol & cnt) = Mid(Sheet1.Cells(j, strtcol), WorksheetFunction.Search(" ", Sheet1.Cells(j, strtcol), 1) + 2, 2) + 0
 Sheet1.Range(strtcol & j) = WorksheetFunction.Substitute(Sheet1.Cells(j, strtcol), "   ", " ")
 Sheet2.Range(bCol & cnt) = Trim(Mid(Sheet1.Cells(j, strtcol), WorksheetFunction.Search("MR ", Sheet1.Cells(j, strtcol), 1) + 2, 7))
 cnt = cnt + 1
Next

k1 = Sheet2.Cells(Rows.Count, bCol).End(xlUp).Row

Sheet2.Range(bCol & "1:" & cCol & k1).RemoveDuplicates Columns:=Array(1, 2), _
     Header:=xlNo

Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub

--
Regards,
Tom Ogilvy
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.