PDA

View Full Version : Solved: Range Copy to different worksheets



parttime_guy
04-15-2010, 08:06 PM
Dear All,

I have a single sheet with infomation.

The only common element is the word "End"
Need to copy information from the data sheet and paste into different worksheets based on the word "End"

Example pasted below.

Kindly help...


Thx-n-BR

p45cal
04-16-2010, 12:59 AM
Tweak the following?:Sub blah()
Set RangeToSearch = Sheets("OriginalInfo").Columns("B")
TopRow = 1
Set c = RangeToSearch.Find(What:="End", After:=Range("B1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
FirstFind = c.Address
Do
Sheets.Add After:=Sheets(Sheets.Count)
Set NewSht = ActiveSheet
Sheets("OriginalInfo").Rows(TopRow & ":" & c.Row).Copy NewSht.Cells(1)
TopRow = c.Row + 1
Set c = RangeToSearch.FindNext(After:=c)
Loop Until c.Address = FirstFind
End Sub

parttime_guy
04-16-2010, 04:44 AM
Dear P45Cal,

Ur a Star! - Thx for your code :thumb


BR

stanleydgrom
04-16-2010, 06:07 AM
parttime_guy,

The following macro will create the new worksheets with the names in column A.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).





Option Explicit
Option Base 1
Sub CopyData()
' stanleydgrom, 04/16/2010
Dim Ary, a As Long, b As Long, d As Long, rng As Range
Dim c As Range, firstaddress As String, Nws As Worksheet
Application.ScreenUpdating = False
With Sheets(1)
Set rng = .Range("A:A")
b = 0
b = WorksheetFunction.CountA(rng)
If b = 0 Then
MsgBox "There is no data in Sheet(1) to process - macro terminated!"
Application.ScreenUpdating = True
Sheets(1).Activate
Exit Sub
End If
ReDim Ary(1 To b, 1 To 3)
Ary(1, 1) = .Cells(1, 1)
Ary(1, 2) = 1
d = 1
For a = 2 To b Step 1
d = d + 1
Ary(a, 1) = .Range("A" & Ary(a - 1, 2)).End(xlDown).Value
Ary(a, 2) = .Range("A" & Ary(a - 1, 2)).End(xlDown).Row
Next a
For a = 1 To UBound(Ary)
b = 0
With .Columns(2)
Set c = .Find("End", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
b = b + 1
Ary(b, 3) = c.Row
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Next a
For a = LBound(Ary) To UBound(Ary) Step 1
On Error Resume Next
Sheets(Ary(a, 1)).Select
If Err Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ary(a, 1)
On Error GoTo 0
Set Nws = Worksheets(Ary(a, 1))
Nws.Cells.ClearContents
.Range("A" & Ary(a, 2) & ":B" & Ary(a, 3)).Copy Nws.Range("A1")
Next a
End With
Sheets(1).Activate
Erase Ary
Application.ScreenUpdating = True
End Sub




Then run macro "CopyData".