Excel VBA help

[Tiahuana]

I have an excel spreadsheet that lists in rows.
1. I need to read starting with Column A3 and create a new sheet with exactly what is in Column A, (going down)until A is blank.

2. Next I need A2 through AK2 COPIED onto each sheet. (copy into A1:AK2)

3. Last I need to read each cell in A, starting A3 and for each row cut and paste into first empty row in the sheet titled what is in Cell A3

exp:
Total Charges Charges In Alerts Non-Covered
tb $9,768.53 $165.57
bb $7,600.13 $1,163.14

So, the total charges line needs put in each new sheet and there after running this I would have 3 sheets, "Sheet1", "TB", "BB"

BB would look like
Total Charges Charges In Alerts Non-Covered
bb $7,600.13 $1,163.14

TB would look like
Total Charges Charges In Alerts Non-Covered
tb $9,768.53 $165.57

 

[SkipVought]

Hi,

So what code do you have so far?

Where are you stuck?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Tiahuana]

OK, I have it working now. I decided to create a master .txt file with the coders initials on it, so it will be easier to add and remove them as they come and go. So that part is done and complete. What I have now is a .xls document that contains the same data as before, only all the sheet are created with the coders initials.

Here is my code for dividing up the doc. (forgive me I'm not very good with VB, so this is probably sloppy to most of you.)
G1 Contains how many records there will be in the document.
" Public Sub xSort()
d.Open_ "dailyfile.xls", ftExcel
Set myExcel = GetObject(, "Excel.Application")
Dim dBook As Workbook

'********************************************************************************************
'Declare variables and redim array
Dim i As Long
ReDim arCoders(0 To 16) As String
Dim lCoders As Variant
Dim v As Integer
v = 1
Dim Coder As Excel.Worksheet
Dim tmp As Excel.Range
Dim StartCell As String
Dim EndCell As String
Dim z As Integer
Dim a As Integer
Dim b As Integer
Dim tmp1 As String
Dim X As String
'********************************************************************************************
'create array function that uses the CODERS.TXT document in the editworkload file location
i = 0
Open "\CODERS.txt" For Input As #1
Do While Not EOF(1)
Input #1, lCoders
arCoders(i) = lCoders
i = i + 1
'Debug.Print lCoders
Loop
Close #1
'********************************************************************************************
'********************************************************************************************
'creates new worksheets for each of the Coders in the array
'dBook.Activate
Set ws = Worksheets("Sheet1")
Dim NewWks As Worksheet
For Each lCoders In arCoders()
Set NewWks = Worksheets.Add(After:=Sheets("Sheet1"))
NewWks.Name = (lCoders)
Range("A1").Name = "Coder"
Sheets("Sheet1").Select
Range("B2:AK2").Select
Selection.Copy
Sheets(lCoders).Select
Range("B1").Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
'Range("B2", "AK2").Copy Destination:=Worksheets(lCoders).Range("B1", "AK1") 'added line
Next lCoders
ActiveWorkbook.SaveAs Filename:= _
"medrecs.xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ws.Select
'ActiveWorkbook.Close
'********************************************************************************************
z = Range("G1") + 1
a = 1
Do Until (a) = (z)
Range("A2").Select
StartCell = ActiveCell.Offset(a, 0).Select
cdr = ActiveCell.Value
Start = "$A$" & (2 + a)
EndCell = Range(Start).End(xlToRight).Offset(0, 34).Select
HCPCS = ActiveCell.Value
Last = "$AK$" & (2 + a)
Range(Start, Last).Select
Selection.Cut
Sheets(cdr).Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
a = a + 1
On Error GoTo ErrHandler
ws.Select
Loop

ActiveWorkbook.SaveAs Filename:= _
"medrecs.xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ErrHandler:
If Err.Number = 9 Then
cdr = "UNKNOWN"
Range(StartCell, EndCell).Cut Destination:=Worksheets(cdr).Range("A65536").End(xlUp).Offset(3, 0)
Resume Next
End If
End Sub"

cdr pulls the initials.

 

[SkipVought]

woa!

I assume that your source sheet has 4 columns...
[tt]
Total Charges Charges In Alerts Non-Covered
tb $9,768.53 $165.57
bb $7,600.13 $1,163.14
[/tt]
The FIRST is UNNAMED.

Basic approch: Assuming that this column has ALL unique value (no repeating values), you can LOOP on this column of data to COPY the row and then PASTE into the appropriate sheet.

    Dim r As Range, lRow As Long
    
    With ActiveSheet
        For Each r In Range(.[A2], .[A2].End(xlDown))
            r.EntireRow.Copy
            With Sheets(r.Value)
                lRow = .[A1].CurrentRegion.Rows.Count + 1
                .Cells(lRow, "A").PasteSpecial xlPasteAll
            End With
        Next
    End With

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}