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

 

[dazeman27]

still creates an error. Am I supposed to just click on the column letter heading? It's always going to be the same column so maybe it's better to just tell it to use column B?

Is there a way to attach your Excel file in this forum? If I gave you the file maybe it would make things easier.

 

[dazeman27]

It doesn't create new sheets each time now, but it doesn't pull any data for the first user and it still leaves the first sheet sorted since it's getting an error at:

ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value

 

[VoG]

This works for me without error (including the resorting).

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, iCol As Integer, tcol As Long
tcol = 2
iCol = 2
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(ws.Cells(1, 1), ws.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

 

[dazeman27]

That works brilliantly. Is there a way to stop it from copying and pasting after column D? I have the button and some totalling functions on the first sheet in the far right columns that are getting pulled.

Thanks so much for all your help

 

[VoG]

This will copy columns A:D only

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, iCol As Integer, tcol As Long
tcol = 2
iCol = 2
Application.ScreenUpdating = False
With ActiveSheet
    lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = 4
    .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(ws.Cells(1, 1), ws.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

 

[dazeman27]

Awesome! Works perfectly. I'm going to have to study the code and try to learn a lot more about VB.

Thanks

 

[dazeman27]

is there a way to close threads and give you answer credit in this forum?

Thanks

 

[VoG]

Hi. No there isn't any way for you to close the thread or mark it as resolved. As a mod I could (in theory) close it but we only close threads that break the forum rules (e.g. duplicate threads).

 

[mrvain]

Hi VoG,

This lapta-code for populating the worksheets works wonderful. I'm now trying to delete the "to-be created sheet" first before creation (in case of an updated datasheet) but failed. I assume a simple line would do the trick but I was not able to find a suitable code on the net and my own trying failed. Do you have any suggestion.

 

[VoG]

The code that I posted here http://www.mrexcel.com/forum/showpost.php?p=2806842&postcount=13 checks if a sheet exists. If it does it clears that sheet otherwise it adds a new sheet.