VBA Vlookup replacement

wazzab1

New Member
Joined
Jan 26, 2006
Messages
24
Hi guys...

Every month I insert a list of reference numbers...I manualy enter a VLookup formula to extract these entries from my list. I then Filter the different locations (Column B e.g. Noth,South,Midlands)and put those entries on corresponding sheets...

Anybody help with some VB code to automate...

Many Thanks in Advance

Wayne
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Hi Wayne, try this macro which assumes that the source sheet is named 'Sheet1' and the target sheets are named as the value specified in column B. an extra sheet named 'Other' must exist for the code to place data from any target sheets not existing.
Code:
Option Explicit

Sub DisperseData()
Const sSourceSheet As String = "Sheet1"
Const sOtherSheet As String = "Other"

Dim lRow As Long, lRowEnd As Long, lTargetRow As Long
Dim rCell As Range
Dim wsSource As Worksheet, wsTarget As Worksheet

Set wsSource = Sheets(sSourceSheet)

lRowEnd = wsSource.Cells(Rows.Count, "B").End(xlUp).Row

If lRowEnd > 1 Then
    For Each rCell In wsSource.Range("B2:B" & lRowEnd)
        On Error Resume Next
        Set wsTarget = Nothing
        Set wsTarget = Sheets(CStr(rCell.Value))
        On Error GoTo 0
        If wsTarget Is Nothing Then Set wsTarget = Sheets(sOtherSheet)
        lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
        wsTarget.Rows(lTargetRow).Value = wsSource.Rows(rCell.Row).Value
    Next rCell
End If

End Sub
 
Upvote 0
great stuff....HOWEVER...

I first need it to match a list of reference numbers on sheet2 in column A, then extract to those sheets.

Be great if you can (Or anybody) Help

Wayne
 
Upvote 0
Hi Wayne,

So if Sheet1 looks like:
Book1
ABCDE
2$A$25A34$D$25$E$25
3$A$19A42$D$19$E$19
4$A$4A32$D$4$E$4
5$A$5A40$D$5$E$5
6$A$16A14$D$16$E$16
7$A$15A73$D$15$E$15
8$A$17A23$D$17$E$17
9$A$21A63$D$21$E$21
10$A$18A34$D$18$E$18
11$A$20A53$D$20$E$20
12$A$27A53$D$27$E$27
13$A$22A73$D$22$E$22
14
Sheet1


and sheet2 looks like this:
Book1
ABCD
1RefSheet
2A1North
3A2South
4A3East
5A4West
6A5North
7A6South
8A7East
Sheet2


try this macro:
Code:
Sub DisperseData()
Const sSourceSheet As String = "Sheet1"
Const sRefSheet As String = "Sheet2"

Dim lRow As Long, lRowEnd As Long, lTargetRow As Long
Dim rCell As Range
Dim wsSource As Worksheet, wsTarget As Worksheet, wsRef As Worksheet

Set wsSource = Sheets(sSourceSheet)
Set wsRef = Sheets(sRefSheet)

lRowEnd = wsSource.Cells(Rows.Count, "B").End(xlUp).Row

If lRowEnd > 1 Then
    For Each rCell In wsSource.Range("B2:B" & lRowEnd)
        On Error Resume Next
        lRow = 0
        lRow = WorksheetFunction.Match(rCell.Value, wsRef.Columns("A"), 0)
        On Error GoTo 0
        
        If lRow<> 0 Then
            On Error Resume Next
            Set wsTarget = Nothing
            Set wsTarget = Sheets(CStr(wsRef.Cells(lRow, "B").Value))
            On Error GoTo 0
            If Not (wsTarget Is Nothing) Then
                lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
                wsTarget.Rows(lTargetRow).Value = wsSource.Rows(lRow).Value
            End If
        End If
    Next rCell
End If

End Sub
 
Upvote 0
Soooo Close !!!

My only problem is the reference number is just on sheet 2. (No North South etc..)

So Sheet 1

A B C D
1234 North £23 Yes
2311 South £44 Yes
2334 North £66 No

Sheet 2

A
1234
2334

Need to Look up sheet 1 and extract the matched numbers from Sheet2 Column A and Place it on the Sheet Name from Column B on Sheet 1 (Any not in the list on sheet 2 - to go on the Other Sheet)

Many Many Thanks (In advance)

Wayne
 
Upvote 0
#Hi,

Try:
Code:
Option Explicit

Sub DisperseData()
Const sSourceSheet As String = "Sheet1"
Const sRefSheet As String = "Sheet2"
Const sOtherSheet As String = "Other"

Dim lRow As Long, lRowEnd As Long, lTargetRow As Long
Dim rCell As Range
Dim wsSource As Worksheet, wsTarget As Worksheet, wsRef As Worksheet

Set wsSource = Sheets(sSourceSheet)
Set wsRef = Sheets(sRefSheet)

lRowEnd = wsSource.Cells(Rows.Count, "A").End(xlUp).Row

If lRowEnd > 1 Then
    For Each rCell In wsSource.Range("A2:A" & lRowEnd)
        On Error Resume Next
        lRow = 0
        lRow = WorksheetFunction.Match(rCell.Value, wsRef.Columns("A"), 0)
        On Error GoTo 0
        
        Set wsTarget = Nothing
        If lRow <> 0 Then
            On Error Resume Next
            Set wsTarget = Sheets(CStr(wsSource.Cells(rCell.Row, "B").Value))
            On Error GoTo 0
        End If
        
        If wsTarget Is Nothing Then Set wsTarget = Sheets(sOtherSheet)
        If Not (wsTarget Is Nothing) Then
            lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
            wsTarget.Rows(lTargetRow).Value = wsSource.Rows(rCell.Row).Value
        End If
    
    Next rCell
End If

End Sub
 
Upvote 0
#Hi,

Try:
Code:
Option Explicit

Sub DisperseData()
Const sSourceSheet As String = "Sheet1"
Const sRefSheet As String = "Sheet2"
Const sOtherSheet As String = "Other"

Dim lRow As Long, lRowEnd As Long, lTargetRow As Long
Dim rCell As Range
Dim wsSource As Worksheet, wsTarget As Worksheet, wsRef As Worksheet

Set wsSource = Sheets(sSourceSheet)
Set wsRef = Sheets(sRefSheet)

lRowEnd = wsSource.Cells(Rows.Count, "A").End(xlUp).Row

If lRowEnd > 1 Then
    For Each rCell In wsSource.Range("A2:A" & lRowEnd)
        On Error Resume Next
        lRow = 0
        lRow = WorksheetFunction.Match(rCell.Value, wsRef.Columns("A"), 0)
        On Error GoTo 0
        
        Set wsTarget = Nothing
        If lRow <> 0 Then
            On Error Resume Next
            Set wsTarget = Sheets(CStr(wsSource.Cells(rCell.Row, "B").Value))
            On Error GoTo 0
        End If
        
        If wsTarget Is Nothing Then Set wsTarget = Sheets(sOtherSheet)
        If Not (wsTarget Is Nothing) Then
            lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
            wsTarget.Rows(lTargetRow).Value = wsSource.Rows(rCell.Row).Value
        End If
    
    Next rCell
End If

End Sub
 
Upvote 0
This is Soooo Good !!!

You have saved me so much time !!!

Can I be checky and ask a couple more things? : Is it possible to just copy certain columns of the row insead of the whole row? For example Columns A,B,E,F.

Also do I have to put all the entries that are not on the list (Sheet2) on the other tab?

Cheers Wayne
 
Upvote 0
Code:
Option Explicit
Sub DisperseData()
Const sSourceSheet As String = "Sheet1"
Const sRefSheet As String = "Sheet2"
Const sOtherSheet As String = "Other"

Dim lRow As Long, lRowEnd As Long, lTargetRow As Long
Dim rCell As Range
Dim wsSource As Worksheet, wsTarget As Worksheet, wsRef As Worksheet

Set wsSource = Sheets(sSourceSheet)
Set wsRef = Sheets(sRefSheet)

lRowEnd = wsSource.Cells(Rows.Count, "A").End(xlUp).Row

If lRowEnd > 1 Then
    For Each rCell In wsSource.Range("A2:A" & lRowEnd)
        On Error Resume Next
        lRow = 0
        lRow = WorksheetFunction.Match(rCell.Value, wsRef.Columns("A"), 0)
        On Error GoTo 0
        
        Set wsTarget = Nothing
        If lRow <> 0 Then
            On Error Resume Next
            Set wsTarget = Sheets(CStr(wsSource.Cells(rCell.Row, "B").Value))
            On Error GoTo 0
        End If
        
'        Uncomment this line if you want the unmatched entries to go to sheet 'Other'
'        If wsTarget Is Nothing Then Set wsTarget = Sheets(sOtherSheet)

        If Not (wsTarget Is Nothing) Then
            lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1
            lRow = rCell.Row
            wsTarget.Range("A" & lTargetRow, "B" & lTargetRow).Value _
                                   = wsSource.Range("A" & lRow, "B" & lRow).Value
            wsTarget.Range("C" & lTargetRow, "D" & lTargetRow).Value _
                                   = wsSource.Range("E" & lRow, "F" & lRow).Value
        End If
    
    Next rCell
End If

End Sub
 
Upvote 0
Only got to test it this morning and works spot on !!!
:biggrin: :biggrin: :biggrin:

Have managed to tweak the code and now means I'll save so much time on a Friday afternoon I can head down the pub early !!!

Cheers
Wayne
 
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,020
Members
448,543
Latest member
MartinLarkin

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