auto extract data from one sheet to another

[dazeman27]

So here's what I'm trying to do:

I have a sheet that has user data in columns A-D
A= date, B=name, C=job data, D=hours

I've made additional sheets in the same workbook for each users name. I'd like each sheet to pull all the rows with the data A-D for that users name in order to have sorted sheets that can be utilized and printed without the clutter of all users data.

I've tried using functions, but I think I'm stepping into macro territory with this one.

I'm not familiar with visual basic, but I assume it's something like this, minus the poor syntax:

if (Sheet 1, B2:B5000) == "Smith" 
then print (Sheet 1, A2:A5000,B2:B5000,C2:C5000,D2:D5000) to (SmithSheet);
end

If anyone can assist me with this or has an easier way to do it with functions or something, I'd really appreciate it. My goal is to have it sort the data to other sheets on startup and save it, or just put a button on each sheet to populate the data....whatever works best. Again, I've never really strayed beyond functions in Excel. All my programming classes in the past were in Java and Unix.

THanks

V/R

Mike

 

[VoG]

Try this http://www.mrexcel.com/forum/showthread.php?t=396069

Note that both Excel Explosion and my code create the new sheets automatically - don't create them yourself.

 

[dazeman27]

Thanks for the quick reply. The code gets a run-time error when I tried. When you put in a macro code like that should it be put into my first sheet or as a module? I put it in a module and then hit the compile button, but it has a run-time error. I probably need to read some more posts on your site because I'm having a hard time understanding some of the code you directed me to, so I'm not able to tailor it for my own purposes very easily

 

[VoG]

This goes in a regular module and compiles without error

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[dazeman27]

ok, I got it to work now. I still have a few issues; should this run on startup? My work's security settings disable macros so you have to enable them after you open the file and nothing runs automatically. I had to hit alt F11 and run the macro manually. Is there a way to make it run automatically each time and overwrite the data on each user sheet so it doesn't create more sheets?

Also, it created one sheet for the first user with only one of his entries, and then it created a Sheet11 with the rest of that user's entries. However, it created the sheets for the other two users by name with no problems. I'm not sure why it has a problem with one of them.

Finally, is there a way to make the columns stretch to show the whole entry when the sheet is created and is there a way to make the sheet label have a color code? I know how to do this manually, but if it creates a new updated sheet for each user that overwrites the old sheet each time it's opened then I guess I"d have to make it part of the macro.

Thanks so much for the great code and the quick response.

 

[dazeman27]

I just noticed that it also reordered the primary sheet to sort by name so now it's not sorted by date. I'd prefer to keep all the entries for the main sheet in order by date and then just extract user data by name on the other sheets but still keep it in order by date. That's why I had originally thought I would just use something to match the name string. Please let me know if you have any suggestions

thanks

 

[VoG]

This will colour the tabs and autofit the columns, and resort at the end.

It could be that for your first name some entries contained leading or trailing spaces and others didn't.

There is no way to run this automatically if macros are set to disabled by default.

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, tcol As Long
tcol = 2
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            tcol = tcol + 1
            ws.Tab.ColorIndex = tcol
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            ws.Columns.AutoFit
            iStart = iEnd + 1
        End If
    Next i
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[dazeman27]

colors work great. Still has the same problem with creating the first user entry as its own sheet and then a sheet named sheet4 with the rest of the entries for the first user in the column.

Is there a way to add this to a button since I can't have it run auto? Also, how would I get it to just overwrite the old sheets instead of creating additional ones every time I run the macro?

It would be great if it just kept the user sheets and then I could put a button on each that said "update" or something that would pull all of the new entries to their sheet.

Anyways, I don't want to take up too much of your time. Thanks for all of the assistance.

 

[dazeman27]

also errors out at

Next i
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

So, it doesn't resort the originals

 

[VoG]

Maybe this. You can assign it to a button from the Forms toolbar. The button must be on the master sheet

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, tcol As Long
tcol = 2
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            If Not WorksheetExists(.Cells(iStart, iCol).Value) Then
                Sheets.Add after:=Sheets(Sheets.Count)
                Set ws = ActiveSheet
                On Error Resume Next
                ws.Name = .Cells(iStart, iCol).Value
                On Error GoTo 0
                tcol = tcol + 1
                ws.Tab.ColorIndex = tcol
            Else
                Set ws = Sheets(.Cells(iStart, iCol).Value)
                ws.UsedRange.ClearContents
            End If
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            ws.Columns.AutoFit
            iStart = iEnd + 1
        End If
    Next i
    .Range(.Cells(2, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function