PDA

View Full Version : Solved: Need to extract to new workbook



jammer6_9
03-04-2008, 07:51 AM
How can I let this code to save sheets in to new workbook?


Sub CopyData()
Dim Arr(), a, tp As Worksheet, sh As Range
Dim i As Long
Application.ScreenUpdating = False

ReDim Arr(0)
i = -1
With Sheets("SALARY LIST")
For Each sh In Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = sh
Next
End With

Set tp = Sheets("TEMP")
For Each a In Arr
tp.Range("C12") = a

tp.Copy After:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = a

Next

Application.ScreenUpdating = True

End Sub

jammer6_9
03-04-2008, 08:01 AM
File is attache... I just need employee pay slip to be extracted in a new workbook...

jammer6_9
03-04-2008, 11:11 PM
:help


Sub CopyData()
Dim Arr(), a, tp As Worksheet, sh As Range
Dim i As Long
Application.ScreenUpdating = False

'Put names into an array
ReDim Arr(0)
i = -1
With Sheets("SALARY LIST")
For Each sh In Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = sh
Next
End With

'Add name to template
Set tp = Sheets("TEMP")
For Each a In Arr
tp.Range("C12") = a
'Copy to a new sheet
tp.Copy After:=Sheets(Sheets.Count)
'Rename
Sheets(Sheets.Count).Name = a
'Fix values
Sheets(a).Range("A1:A43").Value = Sheets(a).Range("A1:A43").Value 'Having Error here
Next
'Move name sheets to new workbook
Sheets(Arr).Move
Application.ScreenUpdating = True

End Sub

jammer6_9
03-05-2008, 01:58 AM
I FOUND SOLUTION... :whistle:


Sub CopyData()
Dim w As Workbook, ws As Worksheet, ss As Worksheet
Dim Arr(), a, tp As Worksheet, sh As Range
Dim i As Long
Application.ScreenUpdating = False

ReDim Arr(0)
i = -1
With Sheets("SALARY LIST")
For Each sh In Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
i = i + 1
ReDim Preserve Arr(i)
Arr(i) = sh
Next
End With

Set tp = Sheets("TEMP")
For Each a In Arr
tp.Range("C12") = a

tp.Copy after:=Sheets(Sheets.Count)

Sheets(Sheets.Count).Name = a

Next

Application.ScreenUpdating = True

For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "SALARY LIST" And ws.Name <> "TEMP" Then
If w Is Nothing Then
ws.Move
Set w = ActiveWorkbook
Else
ws.Move after:=ss
End If
Set ss = ActiveSheet
End If
Next ws
ThisWorkbook.Activate

End Sub