Trying to copy AREAs to the sheet of the employee whose name is the same as "Ar" in the - For Each Ar In Columns("A").SpecialCells(xlConstants).Areas

If current Ar = Name 1 then the AREA should go to the sheet named Name 1.

I'm using Name 1, Name 2 etc, as sheet names and employee names.

"Main" sheet column 1 has Name n and data for Name n is in columns B to E down any number of rows. Say 5 to 45, varies.

There is a one blank row between AREAs.

The "Set ArCpy As..." works just fine, can't get the copy-to-sheet-name thing correct.

Thanks,
Howard

Sub Staff_Info_To_Staff_Sheet()
Dim Ar As Range
Dim ArRow As Long, ArDwn As Long
Dim ArCpy As Range
Dim sNme As Worksheet

For Each Ar In Columns("A").SpecialCells(xlConstants).Areas

ArDwn = Ar.Offset(, 1).End(xlDown).Row
'Set sNme.Name = Ar.Offset(0, 0)
Set ArCpy = Range(Cells(Ar.Row, 2), Cells(ArDwn, 5))

ArCpy.Copy Sheets(sNme).Range("A" & Rows.Count).End(xlUp)(2)

Next

End Sub

Hi Howard,

Am Sun, 25 Oct 2015 17:30:29 -0700 (PDT) schrieb L. Howard:

Trying to copy AREAs to the sheet of the employee whose name is the same as "Ar" in the - For Each Ar In Columns("A").SpecialCells(xlConstants).Areas

If current Ar = Name 1 then the AREA should go to the sheet named Name 1.

I'm using Name 1, Name 2 etc, as sheet names and employee names.

"Main" sheet column 1 has Name n and data for Name n is in columns B to E down any number of rows. Say 5 to 45, varies.

There is a one blank row between AREAs.

can you send me an example workbook?


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

can you send me an example workbook?


Regards
Claus B.

Hi Claus, thanks for taking a look.

Here is my test workbook.
There are probably other ways to copy the data, I was interested in using the AREAs for the most part. A example to myself, no OP here.

https://www.dropbox.com/s/apxjwd34sg...copy.xlsm?dl=0

Howard

Hi Howard,

Am Mon, 26 Oct 2015 00:19:54 -0700 (PDT) schrieb L. Howard:

https://www.dropbox.com/s/apxjwd34sg...copy.xlsm?dl=0

please download your workbook from
https://onedrive.live.com/redir?resi...=folder%2cxlsm


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

Hi Howard,

Am Mon, 26 Oct 2015 08:35:45 +0100 schrieb Claus Busch:

https://onedrive.live.com/redir?resi...=folder%2cxlsm

or try it this way (macro also at OneDrive in your workbook Module3):

Sub CopyAreas()
Dim LRow As Long, i As Long, n As Long
Dim varFirst() As Variant, varLast() As Variant
Dim rngC As Range, myRng As Range

With Sheets("Main")
LRow = .Cells(Rows.Count, 2).End(xlUp).Row
'Writing the last row of the areas in an array
For Each rngC In .Range("B1:B" & LRow +
1).SpecialCells(xlCellTypeBlanks)
ReDim Preserve varLast(i)
varLast(i) = rngC.Row - 1
i = i + 1
Next
'Writing the first row of the areas in an array
ReDim Preserve varFirst(UBound(varLast))
varFirst(n) = 2
For i = LBound(varLast) To UBound(varLast) - 1
n = n + 1
varFirst(n) = varLast(i) + 3
Next
'Copying the areas
For i = LBound(varFirst) To UBound(varFirst)
Set myRng = .Range(.Cells(varFirst(i), 2), .Cells(varLast(i),
5))
Sheets(.Cells(varFirst(i) - 1, 1).Value).Cells(Rows.Count,
1).End(xlUp)(2) _
.Resize(myRng.Rows.Count, 4).Value = myRng.Value
Next
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional

On Monday, October 26, 2015 at 1:27:32 AM UTC-7, Claus Busch wrote:
Hi Howard,

Am Mon, 26 Oct 2015 08:35:45 +0100 schrieb Claus Busch:

https://onedrive.live.com/redir?resi...=folder%2cxlsm

or try it this way (macro also at OneDrive in your workbook Module3):

Sub CopyAreas()
Dim LRow As Long, i As Long, n As Long
Dim varFirst() As Variant, varLast() As Variant
Dim rngC As Range, myRng As Range

With Sheets("Main")
LRow = .Cells(Rows.Count, 2).End(xlUp).Row
'Writing the last row of the areas in an array
For Each rngC In .Range("B1:B" & LRow +
1).SpecialCells(xlCellTypeBlanks)
ReDim Preserve varLast(i)
varLast(i) = rngC.Row - 1
i = i + 1
Next
'Writing the first row of the areas in an array
ReDim Preserve varFirst(UBound(varLast))
varFirst(n) = 2
For i = LBound(varLast) To UBound(varLast) - 1
n = n + 1
varFirst(n) = varLast(i) + 3
Next
'Copying the areas
For i = LBound(varFirst) To UBound(varFirst)
Set myRng = .Range(.Cells(varFirst(i), 2), .Cells(varLast(i),
5))
Sheets(.Cells(varFirst(i) - 1, 1).Value).Cells(Rows.Count,
1).End(xlUp)(2) _
.Resize(myRng.Rows.Count, 4).Value = myRng.Value
Next
End With
End Sub


Regards
Claus B.

Thanks Claus, as always great stuff indeed.

Is the main problem with my initial code getting the AR name to become a sheet name is that AR is Dimmed as a Range and the sheet name must be a string?

Howard

Một ngày mới làm việc hiệu quả.