I have a set of about 50 source files, each with 5 named ranges (one
name range on each of 5 tabs). I am trying to create a macro to copy
the named ranges for each of the source files to the corresponding tab
of a destination file so that the destination file contains a column
for each source file on each tab. Thus far, I have the following
code:

Dim wbOther As Workbook
Dim PathsList As Range
Dim i As Range
Dim ThePath As String
Dim TheFile As String

Sub CopyBuysheets()
With Sheets("FOLDERS")
Set PathsList = .Range("A2", .Range("A" &
Rows.Count).End(xlUp))
End With
Set wbThis = ThisWorkbook
For Each i In PathsList
ThePath = i.Value
ChDir ThePath
TheFile = Dir("*.xls")
Do While TheFile <> ""
Application.EnableEvents = False
Set wbOther = Workbooks.Open(ThePath & "\" &
TheFile)
Sheets("ABSOLUT").Select
Application.EnableEvents = True
With wbThis.Sheets("ABSOLUT")
Range("ABSOLUT_TOTAL").Copy
.Range("ABSOLUT_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("CRUZAN_TOTAL").Copy
.Range("CRUZAN_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("LEVEL_TOTAL").Copy
.Range("LEVEL_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("PLYMOUTH_TOTAL").Copy
.Range("PLYMOUTH_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("FRIS_TOTAL").Copy
.Range("FRIS_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
End With
wbOther.Close SaveChanges:=False
TheFile = Dir
Loop
Next i
End Sub

The macro fails at the following line with the error message
"Application defined or object defined error."

..Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
Paste:=xlPasteValues

Any advice would be appreciated. TIA

Crownman

Is the code in a standard module?
(It should be.)

Where does .End(xlRight) take you?
(Offset(-1, 1) would be a problem in a first row or last column)

Are you using XL 2007?
(I'm sorry) <g>

--
Jim Cone
Portland, Oregon USA
http://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)



"Crownman"
<crownman451@sbcglobal.net>
wrote in message
I have a set of about 50 source files, each with 5 named ranges (one
name range on each of 5 tabs). I am trying to create a macro to copy
the named ranges for each of the source files to the corresponding tab
of a destination file so that the destination file contains a column
for each source file on each tab. Thus far, I have the following
code:

Dim wbOther As Workbook
Dim PathsList As Range
Dim i As Range
Dim ThePath As String
Dim TheFile As String

Sub CopyBuysheets()
With Sheets("FOLDERS")
Set PathsList = .Range("A2", .Range("A" &
Rows.Count).End(xlUp))
End With
Set wbThis = ThisWorkbook
For Each i In PathsList
ThePath = i.Value
ChDir ThePath
TheFile = Dir("*.xls")
Do While TheFile <> ""
Application.EnableEvents = False
Set wbOther = Workbooks.Open(ThePath & "\" &
TheFile)
Sheets("ABSOLUT").Select
Application.EnableEvents = True
With wbThis.Sheets("ABSOLUT")
Range("ABSOLUT_TOTAL").Copy
.Range("ABSOLUT_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("CRUZAN_TOTAL").Copy
.Range("CRUZAN_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("LEVEL_TOTAL").Copy
.Range("LEVEL_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("PLYMOUTH_TOTAL").Copy
.Range("PLYMOUTH_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
Range("FRIS_TOTAL").Copy
.Range("FRIS_START").End(xlRight).Offset(-1,
1).PasteSpecial Paste:=xlPasteValues
End With
wbOther.Close SaveChanges:=False
TheFile = Dir
Loop
Next i
End Sub

The macro fails at the following line with the error message
"Application defined or object defined error."

..Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
Paste:=xlPasteValues

Any advice would be appreciated. TIA
Crownman

On Apr 30, 9:40*am, "Jim Cone" <james.cone...@comcast.netXXX> wrote:
> Is the code in a standard module? *
> (It should be.)
>
> Where does .End(xlRight) take you?
> (Offset(-1, 1) would be a problem in a first row or last column)
>
> Are you using XL 2007?
> (I'm sorry) <g>
>
> --
> Jim Cone
> Portland, Oregon *USAhttp://www.realezsites.com/bus/primitivesoftware
> (Excel Add-ins / Excel Programming)
>
> "Crownman"
> <crownman...@sbcglobal.net>
> wrote in message
> I have a set of about 50 source files, each with 5 named ranges (one
> name range on each of 5 tabs). *I am trying to create a macro to copy
> the named ranges for each of the source files to the corresponding tab
> of a destination file so that the destination file contains a column
> for each source file on each tab. *Thus far, I have the following
> code:
>
> Dim wbOther As Workbook
> Dim PathsList As Range
> Dim i As Range
> Dim ThePath As String
> Dim TheFile As String
>
> Sub CopyBuysheets()
> * * * With Sheets("FOLDERS")
> * * * * * * Set PathsList = .Range("A2", .Range("A" &
> Rows.Count).End(xlUp))
> * * * End With
> * * * Set wbThis = ThisWorkbook
> * * * For Each i In PathsList
> * * * * * * ThePath = i.Value
> * * * * * * ChDir ThePath
> * * * * * * TheFile = Dir("*.xls")
> * * * * * * Do While TheFile <> ""
> * * * * * * * * * Application.EnableEvents = False
> * * * * * * * * * Set wbOther = Workbooks.Open(ThePath& "\" &
> TheFile)
> * * * * * * * * * Sheets("ABSOLUT").Select
> * * * * * * * * * Application.EnableEvents = True
> * * * * * * * * * With wbThis.Sheets("ABSOLUT")
> * * * * * * * * * * * * Range("ABSOLUT_TOTAL").Copy
> * * * * * * * * * * * * .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("CRUZAN_TOTAL").Copy
> * * * * * * * * * * * * .Range("CRUZAN_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("LEVEL_TOTAL").Copy
> * * * * * * * * * * * * .Range("LEVEL_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("PLYMOUTH_TOTAL").Copy
> * * * * * * * * * * * * .Range("PLYMOUTH_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("FRIS_TOTAL").Copy
> * * * * * * * * * * * * .Range("FRIS_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * End With
> * * * * * * * * * wbOther.Close SaveChanges:=False
> * * * * * * * * * TheFile = Dir
> * * * * * * Loop
> * * * Next i
> End Sub
>
> The macro fails at the following line with the error message
> "Application defined or object defined error."
>
> .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> Paste:=xlPasteValues
>
> Any advice would be appreciated. *TIA
> Crownman

I am using Excel 2003 and the code is in a standard module.
End(xlRight) does take me to the top row and last column of a table as
I need to paste the columns from the source worksheets beginning in
the column next to the table in the destination worksheet.

Is there some other way other than Offset to accomplish this?

Thanks for your help

On Apr 30, 9:40*am, "Jim Cone" <james.cone...@comcast.netXXX> wrote:
> Is the code in a standard module? *
> (It should be.)
>
> Where does .End(xlRight) take you?
> (Offset(-1, 1) would be a problem in a first row or last column)
>
> Are you using XL 2007?
> (I'm sorry) <g>
>
> --
> Jim Cone
> Portland, Oregon *USAhttp://www.realezsites.com/bus/primitivesoftware
> (Excel Add-ins / Excel Programming)
>
> "Crownman"
> <crownman...@sbcglobal.net>
> wrote in message
> I have a set of about 50 source files, each with 5 named ranges (one
> name range on each of 5 tabs). *I am trying to create a macro to copy
> the named ranges for each of the source files to the corresponding tab
> of a destination file so that the destination file contains a column
> for each source file on each tab. *Thus far, I have the following
> code:
>
> Dim wbOther As Workbook
> Dim PathsList As Range
> Dim i As Range
> Dim ThePath As String
> Dim TheFile As String
>
> Sub CopyBuysheets()
> * * * With Sheets("FOLDERS")
> * * * * * * Set PathsList = .Range("A2", .Range("A" &
> Rows.Count).End(xlUp))
> * * * End With
> * * * Set wbThis = ThisWorkbook
> * * * For Each i In PathsList
> * * * * * * ThePath = i.Value
> * * * * * * ChDir ThePath
> * * * * * * TheFile = Dir("*.xls")
> * * * * * * Do While TheFile <> ""
> * * * * * * * * * Application.EnableEvents = False
> * * * * * * * * * Set wbOther = Workbooks.Open(ThePath& "\" &
> TheFile)
> * * * * * * * * * Sheets("ABSOLUT").Select
> * * * * * * * * * Application.EnableEvents = True
> * * * * * * * * * With wbThis.Sheets("ABSOLUT")
> * * * * * * * * * * * * Range("ABSOLUT_TOTAL").Copy
> * * * * * * * * * * * * .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("CRUZAN_TOTAL").Copy
> * * * * * * * * * * * * .Range("CRUZAN_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("LEVEL_TOTAL").Copy
> * * * * * * * * * * * * .Range("LEVEL_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("PLYMOUTH_TOTAL").Copy
> * * * * * * * * * * * * .Range("PLYMOUTH_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * * * Range("FRIS_TOTAL").Copy
> * * * * * * * * * * * * .Range("FRIS_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * End With
> * * * * * * * * * wbOther.Close SaveChanges:=False
> * * * * * * * * * TheFile = Dir
> * * * * * * Loop
> * * * Next i
> End Sub
>
> The macro fails at the following line with the error message
> "Application defined or object defined error."
>
> .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> Paste:=xlPasteValues
>
> Any advice would be appreciated. *TIA
> Crownman

I am using Excel 2003 and the code is in a standard module. End
(xlRight) does take me to the top row and last column of the
worksheet. I am trying to paste the contents of the source files into
a group of coumns beginning one row above and in the next column of
the current worksheet. If Offset is a problem, is there some other
way to accomplish this?

Thanks for your help.

The point I was trying to make is that you can't tell Excel to
paste to a location that is off the worksheet.
The row above the first worksheet row does not exist.
Same for the column to the right of the last column.

Still not quite sure where you are trying to paste the copied cells.
It sounds like one cell up and one cell over from the top right corner
of the named range. So, assuming the named range does not contain
the first row or last column of the worksheet...

Dim lngCols As Long
lngCols = wbOther.Sheets("ABSOLUT") _
..Range("ABSOLUT_START").Columns.Count

wbThis.Sheets("ABSOLUT").Range("ABSOLUT_TOTAL").Co py
wbOther.Sheets("ABSOLUT").Range("ABSOLUT_START") _
..Cells(0, lngCols + 1).PasteSpecial Paste:=xlPasteValues
--
Jim Cone
Portland, Oregon USA
http://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)



> "Crownman"
> <crownman...@sbcglobal.net>
> wrote in message
I am using Excel 2003 and the code is in a standard module. End
(xlRight) does take me to the top row and last column of the
worksheet. I am trying to paste the contents of the source files into
a group of coumns beginning one row above and in the next column of
the current worksheet. If Offset is a problem, is there some other
way to accomplish this?

Thanks for your help.

On Apr 30, 11:23*am, "Jim Cone" <james.cone...@comcast.netXXX> wrote:
> The point I was trying to make is that you can't tell Excel to
> paste to a location that is off the worksheet.
> The row above the first worksheet row does not exist. *
> Same for the column to the right of the last column.
>
> Still not quite sure where you are trying to paste the copied cells.
> It sounds like one cell up and one cell over from the top right corner
> of the named range. *So, assuming the named range does not contain
> the first row or last column of the worksheet...
>
> Dim lngCols As Long
> lngCols = wbOther.Sheets("ABSOLUT") _
> .Range("ABSOLUT_START").Columns.Count
>
> wbThis.Sheets("ABSOLUT").Range("ABSOLUT_TOTAL").Co py
> wbOther.Sheets("ABSOLUT").Range("ABSOLUT_START") _
> .Cells(0, lngCols + 1).PasteSpecial Paste:=xlPasteValues
> --
> Jim Cone
> Portland, Oregon *USAhttp://www.realezsites.com/bus/primitivesoftware
> (Excel Add-ins / Excel Programming)
>
> > "Crownman"
> > <crownman...@sbcglobal.net>
> > wrote in message
>
> I am using Excel 2003 and the code is in a standard module. *End
> (xlRight) does take me to the top row and last column of the
> worksheet. *I am trying to paste the contents of the source files into
> a group of coumns beginning one row above and in the next column of
> the current worksheet. *If Offset is a problem, is there some other
> way to accomplish this?
>
> Thanks for your help.

I guess I am not understanding your suggestions. By changing the
instruction End(xlRight) to End(xlToRight) and using the offsets I was
able to get the data from the first named range on the first tab of
the first source file copied in the proper place on the first tab of
the destination file, but now the macro fails at the same line for the
second named range on the destination file.

I appreciate your help and advice, but I guess I'll just have to
muddle through this on my own.

Thanks once more.

I'm confused over what you're extracting, but this may give you some more ideas:

Option Explicit
Sub CopyBuysheets()

Dim wbOther As Workbook
Dim PathsList As Range
Dim myCell As Range
Dim fCtr As Long
Dim myPath As String
Dim RangeNames As Variant
Dim rCtr As Long
Dim TestRng As Range
Dim myFile As String
Dim myFileNames() As String
Dim iCtr As Long
Dim TestWks As Worksheet
Dim DestCell As Range

RangeNames = Array("absolut_total", _
"Cruzan_Total", _
"level_total", _
"plymouth_Total", _
"fris_total")

With ThisWorkbook.Worksheets("folders")
Set PathsList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With

'retrieve all the names of the files.
fCtr = 0
For Each myCell In PathsList.Cells
myPath = myCell.Value
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.xls")
On Error GoTo 0

Do While myFile <> ""
If LCase(myFile) Like LCase("*.xls") Then
fCtr = fCtr + 1
ReDim Preserve myFileNames(1 To fCtr)
myFileNames(fCtr) = myPath & myFile
End If
myFile = Dir()
Loop
Next myCell

If fCtr > 0 Then
'loop through the list of files
For iCtr = LBound(myFileNames) To UBound(myFileNames)
Application.EnableEvents = False
Set wbOther = Workbooks.Open(Filename:=myFileNames(iCtr))
Application.EnableEvents = True
For rCtr = LBound(RangeNames) To UBound(RangeNames)
Set TestRng = Nothing
On Error Resume Next
Set TestRng = wbOther.Names(RangeNames(rCtr)).RefersToRange
On Error GoTo 0

If TestRng Is Nothing Then
'no range by this name in that workbook
Beep '?
Else
Set TestWks = Nothing
On Error Resume Next
Set TestWks = ThisWorkbook.Worksheets(TestRng.Parent.Name)
On Error GoTo 0

If TestWks Is Nothing Then
Set TestWks = Worksheets.Add
TestWks.Name = TestRng.Parent.Name
End If

With TestWks
Set DestCell = .Cells(1, .Columns.Count).End(xlToLeft)
If IsEmpty(DestCell.Value) Then
'stay put
Else
'move to the column to the right
Set DestCell = DestCell.Offset(0, 1)
End If

DestCell.Value = myFileNames(iCtr) _
& "--" & RangeNames(rCtr)

TestRng.Areas(1).Columns(1).Copy
DestCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
End If
Next rCtr

wbOther.Close savechanges:=False
Next iCtr
End If

End Sub


Crownman wrote:
>
> I have a set of about 50 source files, each with 5 named ranges (one
> name range on each of 5 tabs). I am trying to create a macro to copy
> the named ranges for each of the source files to the corresponding tab
> of a destination file so that the destination file contains a column
> for each source file on each tab. Thus far, I have the following
> code:
>
> Dim wbOther As Workbook
> Dim PathsList As Range
> Dim i As Range
> Dim ThePath As String
> Dim TheFile As String
>
> Sub CopyBuysheets()
> With Sheets("FOLDERS")
> Set PathsList = .Range("A2", .Range("A" &
> Rows.Count).End(xlUp))
> End With
> Set wbThis = ThisWorkbook
> For Each i In PathsList
> ThePath = i.Value
> ChDir ThePath
> TheFile = Dir("*.xls")
> Do While TheFile <> ""
> Application.EnableEvents = False
> Set wbOther = Workbooks.Open(ThePath & "\" &
> TheFile)
> Sheets("ABSOLUT").Select
> Application.EnableEvents = True
> With wbThis.Sheets("ABSOLUT")
> Range("ABSOLUT_TOTAL").Copy
> .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> Range("CRUZAN_TOTAL").Copy
> .Range("CRUZAN_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> Range("LEVEL_TOTAL").Copy
> .Range("LEVEL_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> Range("PLYMOUTH_TOTAL").Copy
> .Range("PLYMOUTH_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> Range("FRIS_TOTAL").Copy
> .Range("FRIS_START").End(xlRight).Offset(-1,
> 1).PasteSpecial Paste:=xlPasteValues
> End With
> wbOther.Close SaveChanges:=False
> TheFile = Dir
> Loop
> Next i
> End Sub
>
> The macro fails at the following line with the error message
> "Application defined or object defined error."
>
> .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> Paste:=xlPasteValues
>
> Any advice would be appreciated. TIA
>
> Crownman

--

Dave Peterson

On Apr 30, 4:52*pm, Dave Peterson <peter...@verizonXSPAM.net> wrote:
> I'm confused over what you're extracting, but this may give you some more ideas:
>
> Option Explicit
> Sub CopyBuysheets()
>
> * * Dim wbOther As Workbook
> * * Dim PathsList As Range
> * * Dim myCell As Range
> * * Dim fCtr As Long
> * * Dim myPath As String
> * * Dim RangeNames As Variant
> * * Dim rCtr As Long
> * * Dim TestRng As Range
> * * Dim myFile As String
> * * Dim myFileNames() As String
> * * Dim iCtr As Long
> * * Dim TestWks As Worksheet
> * * Dim DestCell As Range
>
> * * RangeNames = Array("absolut_total", _
> * * * * * * * * * * * *"Cruzan_Total", _
> * * * * * * * * * * * *"level_total", _
> * * * * * * * * * * * *"plymouth_Total", _
> * * * * * * * * * * * *"fris_total")
>
> * * With ThisWorkbook.Worksheets("folders")
> * * * * Set PathsList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
> * * End With
>
> * * 'retrieve all the names of the files.
> * * fCtr = 0
> * * For Each myCell In PathsList.Cells
> * * * * myPath = myCell.Value
> * * * * If Right(myPath, 1) <> "\" Then
> * * * * * * myPath = myPath & "\"
> * * * * End If
> * * * * myFile = ""
> * * * * On Error Resume Next
> * * * * myFile = Dir(myPath & "*.xls")
> * * * * On Error GoTo 0
>
> * * * * Do While myFile <> ""
> * * * * * * If LCase(myFile) Like LCase("*.xls") Then
> * * * * * * * * *fCtr = fCtr + 1
> * * * * * * * * *ReDim Preserve myFileNames(1 To fCtr)
> * * * * * * * * *myFileNames(fCtr) = myPath & myFile
> * * * * * * End If
> * * * * * * myFile = Dir()
> * * * * Loop
> * * Next myCell
>
> * * If fCtr > 0 Then
> * * * * 'loop through the list of files
> * * * * For iCtr = LBound(myFileNames) To UBound(myFileNames)
> * * * * * * Application.EnableEvents = False
> * * * * * * Set wbOther = Workbooks.Open(Filename:=myFileNames(iCtr))
> * * * * * * Application.EnableEvents = True
> * * * * * * For rCtr = LBound(RangeNames) To UBound(RangeNames)
> * * * * * * * * Set TestRng = Nothing
> * * * * * * * * On Error Resume Next
> * * * * * * * * Set TestRng = wbOther.Names(RangeNames(rCtr)).RefersToRange
> * * * * * * * * On Error GoTo 0
>
> * * * * * * * * If TestRng Is Nothing Then
> * * * * * * * * * * 'no range by this name in that workbook
> * * * * * * * * * * Beep '?
> * * * * * * * * Else
> * * * * * * * * * * Set TestWks = Nothing
> * * * * * * * * * * On Error Resume Next
> * * * * * * * * * * Set TestWks = ThisWorkbook.Worksheets(TestRng.Parent.Name)
> * * * * * * * * * * On Error GoTo 0
>
> * * * * * * * * * * If TestWks Is Nothing Then
> * * * * * * * * * * * * Set TestWks = Worksheets..Add
> * * * * * * * * * * * * TestWks.Name = TestRng.Parent.Name
> * * * * * * * * * * End If
>
> * * * * * * * * * * With TestWks
> * * * * * * * * * * * * Set DestCell = .Cells(1,.Columns.Count).End(xlToLeft)
> * * * * * * * * * * * * If IsEmpty(DestCell.Value)Then
> * * * * * * * * * * * * * * 'stay put
> * * * * * * * * * * * * Else
> * * * * * * * * * * * * * * 'move to the column to the right
> * * * * * * * * * * * * * * Set DestCell = DestCell.Offset(0, 1)
> * * * * * * * * * * * * End If
>
> * * * * * * * * * * * * DestCell.Value = myFileNames(iCtr) _
> * * * * * * * * * * * * * * * * * * * * * * *& "--" & RangeNames(rCtr)
>
> * * * * * * * * * * * * TestRng.Areas(1).Columns(1).Copy
> * * * * * * * * * * * * DestCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues
> * * * * * * * * * * End With
> * * * * * * * * End If
> * * * * * * Next rCtr
>
> * * * * * * wbOther.Close savechanges:=False
> * * * * Next iCtr
> * * End If
>
> End Sub
>
>
>
>
>
> Crownman wrote:
>
> > I have a set of about 50 source files, each with 5 named ranges (one
> > name range on each of 5 tabs). *I am trying to create a macro to copy
> > the named ranges for each of the source files to the corresponding tab
> > of a destination file so that the destination file contains a column
> > for each source file on each tab. *Thus far, I have the following
> > code:
>
> > Dim wbOther As Workbook
> > Dim PathsList As Range
> > Dim i As Range
> > Dim ThePath As String
> > Dim TheFile As String
>
> > Sub CopyBuysheets()
> > * * * With Sheets("FOLDERS")
> > * * * * * * Set PathsList = .Range("A2", .Range("A" &
> > Rows.Count).End(xlUp))
> > * * * End With
> > * * * Set wbThis = ThisWorkbook
> > * * * For Each i In PathsList
> > * * * * * * ThePath = i.Value
> > * * * * * * ChDir ThePath
> > * * * * * * TheFile = Dir("*.xls")
> > * * * * * * Do While TheFile <> ""
> > * * * * * * * * * Application.EnableEvents = False
> > * * * * * * * * * Set wbOther = Workbooks.Open(ThePath & "\" &
> > TheFile)
> > * * * * * * * * * Sheets("ABSOLUT").Select
> > * * * * * * * * * Application.EnableEvents = True
> > * * * * * * * * * With wbThis.Sheets("ABSOLUT")
> > * * * * * * * * * * * * Range("ABSOLUT_TOTAL").Copy
> > * * * * * * * * * * * * .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> > 1).PasteSpecial Paste:=xlPasteValues
> > * * * * * * * * * * * * Range("CRUZAN_TOTAL").Copy
> > * * * * * * * * * * * * .Range("CRUZAN_START").End(xlRight).Offset(-1,
> > 1).PasteSpecial Paste:=xlPasteValues
> > * * * * * * * * * * * * Range("LEVEL_TOTAL").Copy
> > * * * * * * * * * * * * .Range("LEVEL_START").End(xlRight).Offset(-1,
> > 1).PasteSpecial Paste:=xlPasteValues
> > * * * * * * * * * * * * Range("PLYMOUTH_TOTAL").Copy
> > * * * * * * * * * * * * .Range("PLYMOUTH_START")..End(xlRight).Offset(-1,
> > 1).PasteSpecial Paste:=xlPasteValues
> > * * * * * * * * * * * * Range("FRIS_TOTAL").Copy
> > * * * * * * * * * * * * .Range("FRIS_START").End(xlRight).Offset(-1,
> > 1).PasteSpecial Paste:=xlPasteValues
> > * * * * * * * * * End With
> > * * * * * * * * * wbOther.Close SaveChanges:=False
> > * * * * * * * * * TheFile = Dir
> > * * * * * * Loop
> > * * * Next i
> > End Sub
>
> > The macro fails at the following line with the error message
> > "Application defined or object defined error."
>
> > .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> > Paste:=xlPasteValues
>
> > Any advice would be appreciated. *TIA
>
> > Crownman
>
> --
>
> Dave Peterson- Hide quoted text -
>
> - Show quoted text -

Dave:

This is getting close. Although I won't pretend to understand exactly
what your code does, it appears to be properly copying the correct
data from each of the source files to the proper page of the
destination file.

I think that the only thing that is needed now is to get the data
copied to the right location on the destination file. The starting
destination location is Row 10 & Column K for each worksheet contained
in the destination workbook.

If you can guide me on how to accomplish this, I think that will get
it done.

Thank you for your help.

Tom Collins

I like including the workbook name in the output. Then I'll know where the data
came from and I know that I can use that row to find the next open cell/column.

Try:

With TestWks
Set DestCell = .Cells(10, .Columns.Count).End(xlToLeft)
if destcell.column < 11 then
set destcell = .cells(10,"K")
end if
If IsEmpty(DestCell.Value) Then
'stay put
Else
'move to the column to the right
Set DestCell = DestCell.Offset(0, 1)
End If



Crownman wrote:
>
> On Apr 30, 4:52 pm, Dave Peterson <peter...@verizonXSPAM.net> wrote:
> > I'm confused over what you're extracting, but this may give you some more ideas:
> >
> > Option Explicit
> > Sub CopyBuysheets()
> >
> > Dim wbOther As Workbook
> > Dim PathsList As Range
> > Dim myCell As Range
> > Dim fCtr As Long
> > Dim myPath As String
> > Dim RangeNames As Variant
> > Dim rCtr As Long
> > Dim TestRng As Range
> > Dim myFile As String
> > Dim myFileNames() As String
> > Dim iCtr As Long
> > Dim TestWks As Worksheet
> > Dim DestCell As Range
> >
> > RangeNames = Array("absolut_total", _
> > "Cruzan_Total", _
> > "level_total", _
> > "plymouth_Total", _
> > "fris_total")
> >
> > With ThisWorkbook.Worksheets("folders")
> > Set PathsList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
> > End With
> >
> > 'retrieve all the names of the files.
> > fCtr = 0
> > For Each myCell In PathsList.Cells
> > myPath = myCell.Value
> > If Right(myPath, 1) <> "\" Then
> > myPath = myPath & "\"
> > End If
> > myFile = ""
> > On Error Resume Next
> > myFile = Dir(myPath & "*.xls")
> > On Error GoTo 0
> >
> > Do While myFile <> ""
> > If LCase(myFile) Like LCase("*.xls") Then
> > fCtr = fCtr + 1
> > ReDim Preserve myFileNames(1 To fCtr)
> > myFileNames(fCtr) = myPath & myFile
> > End If
> > myFile = Dir()
> > Loop
> > Next myCell
> >
> > If fCtr > 0 Then
> > 'loop through the list of files
> > For iCtr = LBound(myFileNames) To UBound(myFileNames)
> > Application.EnableEvents = False
> > Set wbOther = Workbooks.Open(Filename:=myFileNames(iCtr))
> > Application.EnableEvents = True
> > For rCtr = LBound(RangeNames) To UBound(RangeNames)
> > Set TestRng = Nothing
> > On Error Resume Next
> > Set TestRng = wbOther.Names(RangeNames(rCtr)).RefersToRange
> > On Error GoTo 0
> >
> > If TestRng Is Nothing Then
> > 'no range by this name in that workbook
> > Beep '?
> > Else
> > Set TestWks = Nothing
> > On Error Resume Next
> > Set TestWks = ThisWorkbook.Worksheets(TestRng.Parent.Name)
> > On Error GoTo 0
> >
> > If TestWks Is Nothing Then
> > Set TestWks = Worksheets.Add
> > TestWks.Name = TestRng.Parent.Name
> > End If
> >
> > With TestWks
> > Set DestCell = .Cells(1, .Columns.Count).End(xlToLeft)
> > If IsEmpty(DestCell.Value) Then
> > 'stay put
> > Else
> > 'move to the column to the right
> > Set DestCell = DestCell.Offset(0, 1)
> > End If
> >
> > DestCell.Value = myFileNames(iCtr) _
> > & "--" & RangeNames(rCtr)
> >
> > TestRng.Areas(1).Columns(1).Copy
> > DestCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues
> > End With
> > End If
> > Next rCtr
> >
> > wbOther.Close savechanges:=False
> > Next iCtr
> > End If
> >
> > End Sub
> >
> >
> >
> >
> >
> > Crownman wrote:
> >
> > > I have a set of about 50 source files, each with 5 named ranges (one
> > > name range on each of 5 tabs). I am trying to create a macro to copy
> > > the named ranges for each of the source files to the corresponding tab
> > > of a destination file so that the destination file contains a column
> > > for each source file on each tab. Thus far, I have the following
> > > code:
> >
> > > Dim wbOther As Workbook
> > > Dim PathsList As Range
> > > Dim i As Range
> > > Dim ThePath As String
> > > Dim TheFile As String
> >
> > > Sub CopyBuysheets()
> > > With Sheets("FOLDERS")
> > > Set PathsList = .Range("A2", .Range("A" &
> > > Rows.Count).End(xlUp))
> > > End With
> > > Set wbThis = ThisWorkbook
> > > For Each i In PathsList
> > > ThePath = i.Value
> > > ChDir ThePath
> > > TheFile = Dir("*.xls")
> > > Do While TheFile <> ""
> > > Application.EnableEvents = False
> > > Set wbOther = Workbooks.Open(ThePath & "\" &
> > > TheFile)
> > > Sheets("ABSOLUT").Select
> > > Application.EnableEvents = True
> > > With wbThis.Sheets("ABSOLUT")
> > > Range("ABSOLUT_TOTAL").Copy
> > > .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> > > 1).PasteSpecial Paste:=xlPasteValues
> > > Range("CRUZAN_TOTAL").Copy
> > > .Range("CRUZAN_START").End(xlRight).Offset(-1,
> > > 1).PasteSpecial Paste:=xlPasteValues
> > > Range("LEVEL_TOTAL").Copy
> > > .Range("LEVEL_START").End(xlRight).Offset(-1,
> > > 1).PasteSpecial Paste:=xlPasteValues
> > > Range("PLYMOUTH_TOTAL").Copy
> > > .Range("PLYMOUTH_START").End(xlRight).Offset(-1,
> > > 1).PasteSpecial Paste:=xlPasteValues
> > > Range("FRIS_TOTAL").Copy
> > > .Range("FRIS_START").End(xlRight).Offset(-1,
> > > 1).PasteSpecial Paste:=xlPasteValues
> > > End With
> > > wbOther.Close SaveChanges:=False
> > > TheFile = Dir
> > > Loop
> > > Next i
> > > End Sub
> >
> > > The macro fails at the following line with the error message
> > > "Application defined or object defined error."
> >
> > > .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> > > Paste:=xlPasteValues
> >
> > > Any advice would be appreciated. TIA
> >
> > > Crownman
> >
> > --
> >
> > Dave Peterson- Hide quoted text -
> >
> > - Show quoted text -
>
> Dave:
>
> This is getting close. Although I won't pretend to understand exactly
> what your code does, it appears to be properly copying the correct
> data from each of the source files to the proper page of the
> destination file.
>
> I think that the only thing that is needed now is to get the data
> copied to the right location on the destination file. The starting
> destination location is Row 10 & Column K for each worksheet contained
> in the destination workbook.
>
> If you can guide me on how to accomplish this, I think that will get
> it done.
>
> Thank you for your help.
>
> Tom Collins

--

Dave Peterson

On May 1, 9:59*am, Dave Peterson <peter...@verizonXSPAM.net> wrote:
> I like including the workbook name in the output. *Then I'll know where the data
> came from and I know that I can use that row to find the next open cell/column.
>
> Try:
>
> * * * * * * * * * * With TestWks
> * * * * * * * * * * * * Set DestCell = .Cells(10, .Columns.Count).End(xlToLeft) *
> * * * * * * * * * * * * if destcell.column < 11 then
> * * * * * * * * * * * * * * set destcell = .cells(10,"K")
> * * * * * * * * * * * * end if * * * * ** * * * * *
> * * * * * * * * * * * * If IsEmpty(DestCell.Value)Then
> * * * * * * * * * * * * * * 'stay put
> * * * * * * * * * * * * Else
> * * * * * * * * * * * * * * 'move to the column to the right
> * * * * * * * * * * * * * * Set DestCell = DestCell.Offset(0, 1)
> * * * * * * * * * * * * End If
>
>
>
>
>
> Crownman wrote:
>
> > On Apr 30, 4:52 pm, Dave Peterson <peter...@verizonXSPAM.net> wrote:
> > > I'm confused over what you're extracting, but this may give you some more ideas:
>
> > > Option Explicit
> > > Sub CopyBuysheets()
>
> > > * * Dim wbOther As Workbook
> > > * * Dim PathsList As Range
> > > * * Dim myCell As Range
> > > * * Dim fCtr As Long
> > > * * Dim myPath As String
> > > * * Dim RangeNames As Variant
> > > * * Dim rCtr As Long
> > > * * Dim TestRng As Range
> > > * * Dim myFile As String
> > > * * Dim myFileNames() As String
> > > * * Dim iCtr As Long
> > > * * Dim TestWks As Worksheet
> > > * * Dim DestCell As Range
>
> > > * * RangeNames = Array("absolut_total", _
> > > * * * * * * * * * * * *"Cruzan_Total", _
> > > * * * * * * * * * * * *"level_total", _
> > > * * * * * * * * * * * *"plymouth_Total", _
> > > * * * * * * * * * * * *"fris_total")
>
> > > * * With ThisWorkbook.Worksheets("folders")
> > > * * * * Set PathsList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
> > > * * End With
>
> > > * * 'retrieve all the names of the files.
> > > * * fCtr = 0
> > > * * For Each myCell In PathsList.Cells
> > > * * * * myPath = myCell.Value
> > > * * * * If Right(myPath, 1) <> "\" Then
> > > * * * * * * myPath = myPath & "\"
> > > * * * * End If
> > > * * * * myFile = ""
> > > * * * * On Error Resume Next
> > > * * * * myFile = Dir(myPath & "*.xls")
> > > * * * * On Error GoTo 0
>
> > > * * * * Do While myFile <> ""
> > > * * * * * * If LCase(myFile) Like LCase("*.xls") Then
> > > * * * * * * * * *fCtr = fCtr + 1
> > > * * * * * * * * *ReDim Preserve myFileNames(1 To fCtr)
> > > * * * * * * * * *myFileNames(fCtr) = myPath & myFile
> > > * * * * * * End If
> > > * * * * * * myFile = Dir()
> > > * * * * Loop
> > > * * Next myCell
>
> > > * * If fCtr > 0 Then
> > > * * * * 'loop through the list of files
> > > * * * * For iCtr = LBound(myFileNames) To UBound(myFileNames)
> > > * * * * * * Application.EnableEvents = False
> > > * * * * * * Set wbOther = Workbooks.Open(Filename:=myFileNames(iCtr))
> > > * * * * * * Application.EnableEvents = True
> > > * * * * * * For rCtr = LBound(RangeNames) To UBound(RangeNames)
> > > * * * * * * * * Set TestRng = Nothing
> > > * * * * * * * * On Error Resume Next
> > > * * * * * * * * Set TestRng = wbOther.Names(RangeNames(rCtr)).RefersToRange
> > > * * * * * * * * On Error GoTo 0
>
> > > * * * * * * * * If TestRng Is Nothing Then
> > > * * * * * * * * * * 'no range by this name in thatworkbook
> > > * * * * * * * * * * Beep '?
> > > * * * * * * * * Else
> > > * * * * * * * * * * Set TestWks = Nothing
> > > * * * * * * * * * * On Error Resume Next
> > > * * * * * * * * * * Set TestWks = ThisWorkbook.Worksheets(TestRng.Parent.Name)
> > > * * * * * * * * * * On Error GoTo 0
>
> > > * * * * * * * * * * If TestWks Is Nothing Then
> > > * * * * * * * * * * * * Set TestWks = Worksheets.Add
> > > * * * * * * * * * * * * TestWks.Name = TestRng.Parent.Name
> > > * * * * * * * * * * End If
>
> > > * * * * * * * * * * With TestWks
> > > * * * * * * * * * * * * Set DestCell = .Cells(1, .Columns.Count).End(xlToLeft)
> > > * * * * * * * * * * * * If IsEmpty(DestCell.Value) Then
> > > * * * * * * * * * * * * * * 'stay put
> > > * * * * * * * * * * * * Else
> > > * * * * * * * * * * * * * * 'move to the column to the right
> > > * * * * * * * * * * * * * * Set DestCell = DestCell.Offset(0, 1)
> > > * * * * * * * * * * * * End If
>
> > > * * * * * * * * * * * * DestCell.Value = myFileNames(iCtr) _
> > > * * * * * * * * * * * * * * * * * * * * * * *& "--" & RangeNames(rCtr)
>
> > > * * * * * * * * * * * * TestRng.Areas(1).Columns(1).Copy
> > > * * * * * * * * * * * * DestCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues
> > > * * * * * * * * * * End With
> > > * * * * * * * * End If
> > > * * * * * * Next rCtr
>
> > > * * * * * * wbOther.Close savechanges:=False
> > > * * * * Next iCtr
> > > * * End If
>
> > > End Sub
>
> > > Crownman wrote:
>
> > > > I have a set of about 50 source files, each with 5 named ranges (one
> > > > name range on each of 5 tabs). *I am trying to create a macro to copy
> > > > the named ranges for each of the source files to the corresponding tab
> > > > of a destination file so that the destination file contains a column
> > > > for each source file on each tab. *Thus far, I have the following
> > > > code:
>
> > > > Dim wbOther As Workbook
> > > > Dim PathsList As Range
> > > > Dim i As Range
> > > > Dim ThePath As String
> > > > Dim TheFile As String
>
> > > > Sub CopyBuysheets()
> > > > * * * With Sheets("FOLDERS")
> > > > * * * * * * Set PathsList = .Range("A2", .Range("A" &
> > > > Rows.Count).End(xlUp))
> > > > * * * End With
> > > > * * * Set wbThis = ThisWorkbook
> > > > * * * For Each i In PathsList
> > > > * * * * * * ThePath = i.Value
> > > > * * * * * * ChDir ThePath
> > > > * * * * * * TheFile = Dir("*.xls")
> > > > * * * * * * Do While TheFile <> ""
> > > > * * * * * * * * * Application.EnableEvents = False
> > > > * * * * * * * * * Set wbOther = Workbooks.Open(ThePath & "\" &
> > > > TheFile)
> > > > * * * * * * * * * Sheets("ABSOLUT").Select
> > > > * * * * * * * * * Application.EnableEvents = True
> > > > * * * * * * * * * With wbThis.Sheets("ABSOLUT")
> > > > * * * * * * * * * * * * Range("ABSOLUT_TOTAL").Copy
> > > > * * * * * * * * * * * * .Range("ABSOLUT_START").End(xlRight).Offset(-1,
> > > > 1).PasteSpecial Paste:=xlPasteValues
> > > > * * * * * * * * * * * * Range("CRUZAN_TOTAL").Copy
> > > > * * * * * * * * * * * * .Range("CRUZAN_START").End(xlRight).Offset(-1,
> > > > 1).PasteSpecial Paste:=xlPasteValues
> > > > * * * * * * * * * * * * Range("LEVEL_TOTAL")..Copy
> > > > * * * * * * * * * * * * .Range("LEVEL_START").End(xlRight).Offset(-1,
> > > > 1).PasteSpecial Paste:=xlPasteValues
> > > > * * * * * * * * * * * * Range("PLYMOUTH_TOTAL").Copy
> > > > * * * * * * * * * * * * .Range("PLYMOUTH_START").End(xlRight).Offset(-1,
> > > > 1).PasteSpecial Paste:=xlPasteValues
> > > > * * * * * * * * * * * * Range("FRIS_TOTAL").Copy
> > > > * * * * * * * * * * * * .Range("FRIS_START")..End(xlRight).Offset(-1,
> > > > 1).PasteSpecial Paste:=xlPasteValues
> > > > * * * * * * * * * End With
> > > > * * * * * * * * * wbOther.Close SaveChanges:=False
> > > > * * * * * * * * * TheFile = Dir
> > > > * * * * * * Loop
> > > > * * * Next i
> > > > End Sub
>
> > > > The macro fails at the following line with the error message
> > > > "Application defined or object defined error."
>
> > > > .Range("ABSOLUT_START").End(xlRight).Offset(-1, 1).PasteSpecial
> > > > Paste:=xlPasteValues
>
> > > > Any advice would be appreciated. *TIA
>
> > > > Crownman
>
> > > --
>
> > > Dave Peterson- Hide quoted text -
>
> > > - Show quoted text -
>
> > Dave:
>
> > This is getting close. *Although I won't pretend to understand exactly
> > what your code does, it appears to be properly copying the correct
> > data from each of the source files to the proper page of the
> > destination file.
>
> > I think that the only thing that is needed now is to get the data
> > copied to the right location on the destination file. *The starting
> > destination location is Row 10 & Column K for each worksheet contained
> > in the destination workbook.
>
> > If you can guide me on how to accomplish this, I think that will get
> > it done.
>
> > Thank you for your help.
>
> > Tom Collins
>
> --
>
> Dave Peterson- Hide quoted text -
>
> - Show quoted text -

Dave:

That appears to be working PERFECTLY. The only thing I had to do was
set DestCell one row higher to account for your addition of the path
of the source file which is an excellent addition.

Thanks so much for your help. I never cease to be amazed and how you
guys can write code like this without even seeing the files that the
code works on.

Tom Collins