Macro to find specific text in a column and copy certain cells in different rows to a different sheet

B

Brikkio

New Member
Joined
Sep 10, 2014
Messages
2
Hi Everyone,

I'm a new member and quite a beginner to VBA functions.
After trying different solutions, I decided to pop my first post here hoping to find a solution.

Let's see if I can explain Excel in... words :)

I receive a sheet from an external client which is not ideally set up, I mean it is quite a complex layout (for me) and I'm not able to find a way.

The sheet contains some information I want to pull out on a different sheet/tab and from there I'll make a random selection (I'm using Data Analysis pack for that).

The relevant information I want to be shown on the new tab (called "RPC") will be:
- Data in Column B (to be copied on RPC sheet in Column A)
- Data in Column O (to be copied on RPC sheet in Column B)
- Data in Column Y (to be copied on RPC sheet in Column C)

The result would be similar to the below:

Column A Column B Column C</SPAN>
[TABLE="width: 381"]
<TBODY>[TR]
[TD]Action Code </SPAN>
[/TD]
[TD]Number of calls per Code</SPAN>
[/TD]
[TD]Product</SPAN>
[/TD]
[/TR]
[TR]
[TD]


DCTELIEXEC</SPAN>
[/TD]
[TD]


1</SPAN>
[/TD]
[TD]


3746 000000 00001</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELINOK</SPAN>
[/TD]
[TD]9</SPAN>
[/TD]
[TD]3746 000000 00002</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00003</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00004</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00005</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00006</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00007</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00008</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00009</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00010</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELISOLS</SPAN>
[/TD]
[TD]1</SPAN>
[/TD]
[TD]3746 000000 00011</SPAN>
[/TD]
[/TR]
</TBODY>[/TABLE]


This is the list of Action Codes that has to be identified on Sheet1 between a larger number of Action Codes</SPAN>
[TABLE="width: 95"]
<TBODY>[TR]
[TD]DCTELIEXEC</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELINOK</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELISOLS</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELOEXEC</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELONOK1</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELOSOLS</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELEATP01</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELEOATP01</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELICM01</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELIDEB01</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELOCM01</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELOCM02</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELOCM03</SPAN>
[/TD]
[/TR]
[TR]
[TD]TELOCM04</SPAN>
[/TD]
[/TR]
</TBODY>[/TABLE]



So far I'm able to run the macro and copy only 1 Action Code, because I don't know how to add multiple criteria.

What I would like to get will be a macro which:

- Identifies the above 14 Action Codes between a larger range of codes
- If an Action code has # of calls, macro should be able to identify the same number of Products; after verifying that # of calls equals to # of Product, macro should go to check the next criteria/Action Code - is it possible to have a control formula at this point? such as: "check number of calls, find same number of products; only after that, go to the next criteria"
- All the identified Action Codes, No. of calls and Products should be copied into the "RPC" sheet and appear like that:

Column A Column B Column C</SPAN>
[TABLE="width: 381"]
<TBODY>[TR]
[TD]Action Code </SPAN>
[/TD]
[TD]Number of calls per Code</SPAN>
[/TD]
[TD]Product</SPAN>
[/TD]
[/TR]
[TR]
[TD]


DCTELIEXEC</SPAN>
[/TD]
[TD]


1</SPAN>
[/TD]
[TD]


3746 000000 00001</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELINOK</SPAN>
[/TD]
[TD]9</SPAN>
[/TD]
[TD]3746 000000 00002</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00003</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00004</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00005</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00006</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00007</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00008</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00009</SPAN>
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]3746 000000 00010</SPAN>
[/TD]
[/TR]
[TR]
[TD]DCTELISOLS</SPAN>
[/TD]
[TD]1</SPAN>
[/TD]
[TD]3746 000000 00011</SPAN>
[/TD]
[/TR]
</TBODY>[/TABLE]


The main issue for me is that data referring to the same case are not in the same row.
Example:
the Product linked to Action Code DCTELIEXEC (located in B7) is Y19, whereas the number of calls is in O8

I found a kind of pattern if helps:
Action code is in B Column
Number of call is in Column O + 1 row + 13 columns right
Product is in Column Y + 12 rows down + 23 columns right (from Action Code position)

Based on the thread "Macro to find specific text in a column and copy certain cells in same row to a different sheet"
I'm using the following code, but I can't have the related Product shown aside of it and I don't know how to add multiple criterias (the 14 Action Codes) to the Code of the Macro:


Sub Sheet1()
Dim shts As Worksheet, i As Integer
Application.ScreenUpdating = False
'Sheets("RPC").Range("A2:" & Columns.Count & ":" & Rows.Count).Delete
i = 1
For Each shts In Worksheets
If shts.Name Like "Sheet1*" Then
shts.UsedRange.AutoFilter Field:=2, Criteria1:="DCTELIEXEC"
Sheets(i).Range(Sheets(i).Range("B3:B18084").Offset(1), Sheets(i).Range("B3:B18084").End(xlDown)).Copy _
Sheets("RPC").Range("A" & Rows.Count).End(xlUp).Offset(1)
shts.UsedRange.AutoFilter
End If
i = i + 1
Application.ScreenUpdating = True
Next
End Sub

Please let me know if you need to see the original sheet and give me some instructions on how to upload it.

Thank you very much for your help.

Regards,
Brikkio</SPAN>
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Sort by date Sort by votes
Welcome to the board!

This shows you how to add multiple criteria:
Code: 
Sub Sheet1()
    Dim shts As Worksheet, i As Integer
    
    Application.ScreenUpdating = False
    'Sheets("RPC").Range("A2:" & Columns.Count & ":" & Rows.Count).Delete
    i = 1
    For Each shts In Worksheets
        If shts.Name Like "Sheet1*" Then
            shts.UsedRange.AutoFilter Field:=2, Criteria1:=Array("DCTELIEXEC", "DCTELISOLS", "DCTELONOK1"), Operator:=xlFilterValues
            Sheets(i).Range(Sheets(i).Range("B3:B18084").Offset(1), Sheets(i).Range("B3:B18084").End(xlDown)).Copy _
                Sheets("RPC").Range("A" & Rows.Count).End(xlUp).Offset(1)
            shts.UsedRange.AutoFilter
        End If
        i = i + 1
        Application.ScreenUpdating = True
    Next
End Sub

This will be useful if you want to populate blank cells in the sparse matrix of your results:
Code: 
Sub FillBlanksWithPreviousRow()

    Dim rng As Range
    
    Set rng = Range("A1").CurrentRegion
    rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    rng.Value = rng.Value
    
End Sub

I don't understand: "between a larger number of Action Codes"
 
Upvote 0
Hi Phil,
thanks for your codes and help. I've used the first code and it works fine, but I need to implement it. I mean, I can get all the action codes listed on the array but I can't get the data on the columns on the right. What I need to tell MACRO is: if you find the action code XXXY1 then go to column Y and copy the data.
I've tried with the following after Operator:=xlFilterValues

Sheets(i).Range(Sheets(i).Range("B3:B18084").Offset(1), Sheets(i).Range("B3:B18084").End(xlDown)).Copy _
Sheets("RPC").Range("A:Y" & Rows.Count).End(xlUp).Offset(1)

Where A and Y are the values I'm interested in and I want to be copied to RPC sheet.

So far I can get the A column values but I can't add Y... (debug error)

Is there a way to widen the Range?

Thx
Brikkio
 
Upvote 0
My original code only showed how to select up multiple values in a Pivot Field. If did not read farther than that. My apologies.

I don't believe you can copy the non-visible rows. If you want to keep using the Filter method, you should manually align columns O and Y to B (delete 1 row from the top of column O and 12 rows from the top of column Y), then when you filter for the values in column B the correct rows would be visible. If you do that then this code would work:
Code: 
Option Explicit

Sub FilterAndCopyRowsAndSomeColumns()
    'manually align rows B, O and Y before running this procedure

    Dim shts As Worksheet
    Dim lWriteRow As Long
    Dim lLastSourceRow As Long
    
    Application.ScreenUpdating = False
    lWriteRow = 1   'Will start writing at row 1 of worksheet RPC, event if row 1 is populated
    For Each shts In Worksheets
        If shts.Name Like "Sheet1*" Then
            lLastSourceRow = shts.Range("A" & Rows.Count).End(xlUp).Row
            lWriteRow = lWriteRow + 1
            With shts
                .UsedRange.AutoFilter Field:=2, Criteria1:=Array("DCTELISOLS ", "DCTELISOLS", "DCTELONOK1"), Operator:=xlFilterValues
                .Range("B2:B" & lLastSourceRow).SpecialCells(xlCellTypeVisible).Copy Sheets("RPC").Range("A" & lWriteRow)
                .Range("O2:O" & lLastSourceRow).SpecialCells(xlCellTypeVisible).Copy Sheets("RPC").Range("B" & lWriteRow)
                .Range("Y2:Y" & lLastSourceRow).SpecialCells(xlCellTypeVisible).Copy Sheets("RPC").Range("C" & lWriteRow)
                .UsedRange.AutoFilter
            End With
        End If
        Application.ScreenUpdating = True
    Next
End Sub

This should work with unmodified sheets:
Code: 
Option Explicit

Sub FilterAndCopyRowsAndSomeColumnsFromUnmodifiedWorksheets()
    'Use with unmodified source worksheets

    Dim shts As Worksheet
    Dim lWriteRow As Long
    Dim lLastSourceRow As Long
    Dim lX As Long
    
    Application.ScreenUpdating = False
    lWriteRow = 1   'Will start writing at row 1+1 of worksheet RPC, event if row 2 is populated
    For Each shts In Worksheets
        If shts.Name Like "Sheet1*" Then
            With shts
                .AutoFilterMode = False
                lLastSourceRow = .Range("A" & Rows.Count).End(xlUp).Row
                For lX = 1 To lLastSourceRow
                    If InStr("DCTELISOLS DCTELONOK1 DCTELIEXEC BBB", .Cells(lX, "B").Value) > 0 Then
                        lWriteRow = lWriteRow + 1
                        .Cells(lX, "B").Copy Sheets("RPC").Range("A" & lWriteRow)
                        .Cells(lX, "B").Offset(1, 13).Copy Sheets("RPC").Range("B" & lWriteRow)
                        .Cells(lX, "B").Offset(12, 23).Copy Sheets("RPC").Range("C" & lWriteRow)
                    End If
                Next
            End With
        End If
        Application.ScreenUpdating = True
    Next
End Sub
 
Upvote 0
I am also new to this board, a relative novice VBA user, and have a similar issue. I would like to write a macro that will run in one workbook to prompt the user to open a 2nd workbook, find a value in specified column on a specified sheet in that workbook and copy a 4-row by 10-column array that begins 2 rows down and 3 columns to the right of that found value, and then paste/special/values that array into the starting location in the first workbook. I know the code for a message box to prompt the user to open the 2nd workbook, and the code to find the specified value in the speicfied column, copying an array in a given sheet, but I need help putting it all together. Any help with the coding would be greatly appreciated.

Thanks!

jsm (aka "LittleOldandSlow")
 
Upvote 0
Welcome to the Board!

It is generally better to start a new thread with your specific problem and reference a similar one. That keeps each thread more focused.
Code: 
Option Explicit

Sub OpenFile()

    Dim vFilePathName As Variant
    Dim sFileName As String
    Dim sFileNameExt As String
    Dim sFileExt As String
    Dim sFilePath As String
    Dim lNameStarts As Long
    Dim lExtensionStarts As Long
    
    vFilePathName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
        , "Select Second File", "Select")
    If vFilePathName = False Then GoTo End_Sub
    
    lNameStarts = InStrRev(vFilePathName, "\")
    sFilePath = Left(vFilePathName, lNameStarts)
    sFileNameExt = Mid(vFilePathName, lNameStarts + 1)
    lExtensionStarts = InStrRev(sFileNameExt, ".")
    sFileName = Left(sFileNameExt, lExtensionStarts - 1)
    sFileExt = Mid(sFileNameExt, lExtensionStarts + 1)

    Workbooks.Open Filename:=vFilePathName

    MsgBox "Select the reference data then run the GetData procedure.", , "Select Reference Cell"

End_Sub:
End Sub


Sub GetData()

    Dim iAnswer As VbMsgBoxResult
    Dim rngTarget As Range
    
    Set rngTarget = ThisWorkbook.Worksheets("Sheet1").Range("A1")
    
    If Selection.Cells.Count > 1 Then
        MsgBox " Select a single cell and run code again.", , "Select 1 Cell"
        GoTo End_Sub:
    End If
    
    iAnswer = MsgBox("Select 'Yes' to process the reference cell: " & _
        Selection.Address(False, False) & vbLf & "which contains: " & _
        Selection.Value, vbYesNo + vbDefaultButton2, "Process Selected Cell?")
    If iAnswer <> vbYes Then GoTo End_Sub
    
    Selection.Offset(2, 3).Range(Cells(1, 1), Cells(4, 10)).Copy _
        Destination:=rngTarget
    
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close
    
End_Sub:

    Set rngTarget = Nothing
    
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA code for copying ranges from multiple sheets to separate columns on new sheet
Replies
7
Views
246
CrishaG
C
ChrisMac1
  • Question Question
VBA - Compare specific data in one column on one sheet, with the same column on 4 other sheets, copy specific cells if match found.
Replies
1
Views
369
ChrisMac1
ChrisMac1
L
  • Solved
Advice on copying and pasting single cell value to cells on different sheet - number of which specified
2
Replies
10
Views
364
LPepito
L
M
  • Solved
Copy and paste multiple matching rows to a new sheet
Replies
7
Views
645
SamKhem
S
P
  • Question Question
copy data from one column and paste to another as values for multiple worksheet
Replies
0
Views
439
priisha
P

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

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