Help with Macro

C

Crownman

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
 
J

Jim Cone

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"
<[email protected]>
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
 
C

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  USAhttp://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)

"Crownman"
<[email protected]>
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
Click to expand...

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
 
C

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  USAhttp://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)

"Crownman"
<[email protected]>
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
Click to expand...

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.
 
J

Jim Cone

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").Copy
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"
<[email protected]>
wrote in message
Click to expand...
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.
 
C

Crownman

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").Copy
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)


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.
Click to expand...

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.
 
D

Dave Peterson

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
 
C

Crownman

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












--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

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
 
D

Dave Peterson

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
 
C

Crownman

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










--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

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
 
D

Dave Peterson

Glad you got it working.

Sometimes adding that little bit of info is helpful in multiple ways--either
making sure you can find the next location to paste and knowing what info came
from what file.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Another macro Question 3
VBA Coding Help for Beginner 0
Should I be content with the time code takes? 2
A simple if <> nn then Msgbox "No Match" 5
Select Case Code does not run... 10
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
Copy columns and paste with blank column between 5
Macro to email via MAC (Code for Outlook working) 1

Top