Returning values from 1 sheet based on a single value in another

R

rickf19

Board Regular
Joined
Aug 30, 2019
Messages
66
Office Version
  1. 2016
Platform
  1. Windows
Hi all

I have a spreadsheet of data that has 6 columns B,H,I,J,L which I want to pull all the rows that have a specific value in COL E

EG

B = Period
H = Date
I = Detail
J = Amount
L= Ref

E = Code

I want to create a number of Tabs that will pull out the data in each of the B to L columns based on the value in Col E
I could just filter the data sheet on the values in Col E and copy/paste to each tab, but the data sheet is updated regularly and there are approx 45 different codes to create sheets for.


Any help gratefully received
Rick
 
Sort by date Sort by votes
Managed to set up macro and attach to button cell A1
but get this error Run time error '9'
Subscript out of range

any ideas

Thanks
Rick

macro error.png
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
That means there's no worksheet named "Tab".
I thought the name of the worksheet that has the dataset was "Tab"?
Can you share a picture of the project explorer so that I can see ALL the sheets you have, like below:

Capture.PNG
 
Upvote 0
Sorry no sheets called Tab my fault for the confusion.

Screenshot below



Thanks
Rick
 

Attachments

  • Screenshot 2021-03-15 162209.png
    Screenshot 2021-03-15 162209.png
    57.1 KB · Views: 7
Upvote 0
Ok, replace all the code with this one:
VBA Code: 
Sub OutputDatasetBasedOnCode2()
    Dim d As Object, lr As Long
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    
    With Sheets("Data")
    
        'Get all codes in column E
        lr = .Cells(Rows.Count, "E").End(xlUp).Row
        For i = 5 To lr
            d.Item(.Cells(i, "E").Value) = "Code2"
        Next i
        Debug.Print "==========" & vbCrLf & "Codes:"
        For i = 0 To d.Count - 1
            Debug.Print d.keys()(i)
        Next i
        
        Dim ws As Worksheet, j As Long
        
        'Create sheets named after the codes
        Application.DisplayAlerts = False
        For i = 0 To d.Count - 1
            If SheetExists(CStr(d.keys()(i))) Then
                Sheets(CStr(d.keys()(i))).Delete
            End If
            Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = d.keys()(i)
            For j = 1 To 5
                ws.Cells(1, j).Value = Choose(j, "Period", "Date", "Detail", "Amount", "Ref")
            Next j
        Next i
        Application.DisplayAlerts = True
        
        Dim fnd As Range, tempFnd As Range, lrForOutput As Long
        
        'Output values
        For i = 0 To d.Count - 1
            Set fnd = .Range("E4:E" & lr).Find(d.keys()(i))
            Set tempFnd = fnd
            Do While Not fnd Is Nothing
                lrForOutput = Sheets(CStr(d.keys()(i))).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "A") = .Cells(fnd.Row, "B")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "B") = .Cells(fnd.Row, "H")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "C") = .Cells(fnd.Row, "I")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "D") = .Cells(fnd.Row, "J")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "E") = .Cells(fnd.Row, "L")
                Set fnd = .Range("E4:E" & lr).FindNext(fnd)
                If fnd.Address = tempFnd.Address Then Exit Do
            Loop
        Next i

        Application.ScreenUpdating = True
        MsgBox "Dataset for the following codes have been exported:" & vbCrLf & vbCrLf & Join(d.keys, ", ")

    End With
End Sub

Function SheetExists(SheetName As String) As Boolean
    SheetExists = False
    For Each Sheet In Sheets
        If Sheet.Name = SheetName Then
            SheetExists = True
            Exit Function
        End If
    Next Sheet
End Function
 
Upvote 0
Hi
getting error here
Run time error 1004
Method "Name of object'_Worksheet' failed
 

Attachments

  • Screenshot 2021-03-15 164546.png
    Screenshot 2021-03-15 164546.png
    64.4 KB · Views: 7
Upvote 0
Replace all the code with this one and give it another try:
VBA Code: 
Sub OutputDatasetBasedOnCode2()
    Dim d As Object, lr As Long
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Call ReplaceInvalidCharacters
  
    With Sheets("Data")
  
        'Get all codes in column E
        lr = .Cells(Rows.Count, "E").End(xlUp).Row
        For i = 5 To lr
            d.Item(.Cells(i, "E").Value) = "Code2"
        Next i
        Debug.Print "==========" & vbCrLf & "Codes:"
        For i = 0 To d.Count - 1
            Debug.Print d.keys()(i)
        Next i
      
        Dim ws As Worksheet, j As Long
      
        'Create sheets named after the codes
        Application.DisplayAlerts = False
        For i = 0 To d.Count - 1
            If SheetExists(CStr(d.keys()(i))) Then
                Sheets(CStr(d.keys()(i))).Delete
            End If
            Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = d.keys()(i)
            For j = 1 To 5
                ws.Cells(1, j).Value = Choose(j, "Period", "Date", "Detail", "Amount", "Ref")
            Next j
        Next i
        Application.DisplayAlerts = True
      
        Dim fnd As Range, tempFnd As Range, lrForOutput As Long
      
        'Output values
        For i = 0 To d.Count - 1
            Set fnd = .Range("E4:E" & lr).Find(d.keys()(i))
            Set tempFnd = fnd
            Do While Not fnd Is Nothing
                lrForOutput = Sheets(CStr(d.keys()(i))).Cells(Rows.Count, "A").End(xlUp).Row + 1
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "A") = .Cells(fnd.Row, "B")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "B") = .Cells(fnd.Row, "H")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "C") = .Cells(fnd.Row, "I")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "D") = .Cells(fnd.Row, "J")
                Sheets(CStr(d.keys()(i))).Cells(lrForOutput, "E") = .Cells(fnd.Row, "L")
                Set fnd = .Range("E4:E" & lr).FindNext(fnd)
                If fnd.Address = tempFnd.Address Then Exit Do
            Loop
        Next i

        Application.ScreenUpdating = True
        MsgBox "Dataset for the following codes have been exported:" & vbCrLf & vbCrLf & Join(d.keys, ", ")

    End With
End Sub

Function SheetExists(SheetName As String) As Boolean
    SheetExists = False
    For Each Sheet In Sheets
        If Sheet.Name = SheetName Then
            SheetExists = True
            Exit Function
        End If
    Next Sheet
End Function

Sub ReplaceInvalidCharacters()
    Dim lr As Long, i As Long
  
    With Sheets("Data")
  
        lr = .Cells(Rows.Count, "E").End(xlUp).Row
        For i = 5 To lr
            If InStr(CStr(.Cells(i, "E").Value), "\") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "\", "_")
            If InStr(CStr(.Cells(i, "E").Value), "/") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "/", "_")
            If InStr(CStr(.Cells(i, "E").Value), "*") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "*", "_")
            If InStr(CStr(.Cells(i, "E").Value), "?") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "?", "_")
            If InStr(CStr(.Cells(i, "E").Value), ":") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, ":", "_")
            If InStr(CStr(.Cells(i, "E").Value), "[") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "[", "_")
            If InStr(CStr(.Cells(i, "E").Value), "]") > 0 Then .Cells(i, "E").Value = Replace(.Cells(i, "E").Value, "]", "_")
        Next i
    End With
End Sub
 
Last edited:
Upvote 0
Hi
thanks again for your efforts
unfortunately another error
Would fully understand if this is becoming a pain

Rick
 

Attachments

  • Screenshot 2021-03-16 093003.png
    Screenshot 2021-03-16 093003.png
    77.3 KB · Views: 4
Upvote 0
It seems the code itself isn't going through an error now.
The error in the image means you have duplicate procedures with the same name.
This means you pasted my code without deleting the code you had been using.
I figured from your previous posts that you have several standard modules, so if you don't have other codes delete all standard modules and insert a new one, then paste the code in #16 into it.
If you have other codes, remove duplicates and give it another try.
 
Upvote 0
Hi
X400 error

screenshot of project screen , might be me not setting it up properly

Thanks
Rick
 

Attachments

  • Screenshot 2021-03-16 102243.png
    Screenshot 2021-03-16 102243.png
    170.9 KB · Views: 3
Upvote 0
The last attempt created some sheets with headings but no data
 
Upvote 0
You must log in or register to reply here.

Similar threads

DNapoli
  • Solved
Index and Match Excel Question.
2 3
Replies
24
Views
442
Peter_SSs
Peter_SSs
L
  • Question
Excel VBA - Return Specific Data from Master Sheet Based on Date Search + Duplicate Certain Items
Replies
1
Views
445
LookingForHelp1
L
S
  • Solved
Lookup using IF/Match returning wrong values
Replies
2
Views
120
sundodger
S
P
  • Question
Return a value from a table that is in the top n percent of a person's trial scores
2
Replies
13
Views
409
Fluff
Fluff
MartinS
  • Question
Update FormatConditions Shifts Column/Row Reference
Replies
0
Views
40
MartinS
MartinS

Forum statistics

Threads
1,214,929
Messages
6,122,317
Members
449,081
Latest member
tanurai

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