Extracting Data and Inserting using VBA

[happyhungarian]

Hi,

I need help building a code that will pull certain data from a list and insert it onto another tab within a certain range of cells. Example: I have a list of employees with their department numbers. I need to be able to have a macro that will split the employees up based upon their departments and insert them onto seperate, specified tabs. Also, I need the range in which they are inserted to be able to expand if the number of employees is greater than the range (i.e. I need the employees names to land between cells C20 and C65. If there are more than 45 employees (65-20), I need the macro to insert rows between C20 and C65 in order to have room for the list of names. I hope that made sense.

Thank you all in advance for your help,

Jesse

 

[VoG]

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

 

[happyhungarian]

It sounds like this is exactly what I am looking for but I am a bit confused by the VBA (I'm relatively novice). In what part of the code do I enter the range to which I want the data copied from and copied to?

Thank you again for your help,

Jesse

 

[VoG]

Try running this

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, t As Date
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
t = Now
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
MsgBox "Completed in " & Format(Now - t, "hh:mm:ss.00"), vbInformation
End Sub

 

[happyhungarian]

A warning sign pops up and just says "400"

 

[VoG]

The master master sheet must be selected.

The code works fine for me, Click Debug - which line is highlighted?

 

[happyhungarian]

This is very strange... I can't get this to work for the life of me. When it prompts me to "Click in the column to extract by" what exactly is that asking me to do? It will create a new tab with the name an office but that tab won't contain any info and it only creates one tab... not a tab for every office... I know I'm doin something wrong