Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > For the hard one -- myabe Tom??
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 209
Default For the hard one -- myabe Tom??
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy only the
values

' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange ref. to

Regards alvin



Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 11,123
Default For the hard one -- myabe Tom??
Hi alvin

Disable the events

See the info on top of my page
http://www.rondebruin.nl/copy4.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl



"Alvin Hansen" wrote in message ...
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy only the
values

' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange ref. to

Regards alvin





Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 27,285
Default For the hard one -- myabe Tom??
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the
' code below to copy only the values
' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

is what I believe Ron is suggesting and it sounds good to me.

--
Regards,
Tom Ogilvy


"Ron de Bruin" wrote in message
...
Hi alvin

Disable the events

See the info on top of my page
http://www.rondebruin.nl/copy4.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl



"Alvin Hansen" wrote in message
...
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy only
the
values

' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange ref.
to

Regards alvin







Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 209
Default For the hard one -- myabe Tom??
well then this doen't work
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub
When i try to update the sheet nothing happens it dosn't change the picture
MAybe i shall give up on this?

regards alvin


"Tom Ogilvy" skrev:

Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the
' code below to copy only the values
' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

is what I believe Ron is suggesting and it sounds good to me.

--
Regards,
Tom Ogilvy


"Ron de Bruin" wrote in message
...
Hi alvin

Disable the events

See the info on top of my page
http://www.rondebruin.nl/copy4.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl



"Alvin Hansen" wrote in message
...
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy only
the
values

' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange ref.
to

Regards alvin








Reply With QuoteReply With Quote
  #5   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 27,285
Default For the hard one -- myabe Tom??
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True

Turned the events off, turned them back on. If it worked before, it should
work now. (Unless you had an error in mybook.close True and it never
reached the line to turne them back on - in that case, run this code:)

Sub AllowEvents()
Application.EnableEvents = True
End Sub

--
Regards,
Tom Ogilvy


"Alvin Hansen" wrote in message
...
well then this doen't work
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub
When i try to update the sheet nothing happens it dosn't change the
picture
MAybe i shall give up on this?

regards alvin


"Tom Ogilvy" skrev:

Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the
' code below to copy only the values
' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

is what I believe Ron is suggesting and it sounds good to me.

--
Regards,
Tom Ogilvy


"Ron de Bruin" wrote in message
...
Hi alvin

Disable the events

See the info on top of my page
http://www.rondebruin.nl/copy4.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl



"Alvin Hansen" wrote in
message
...
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy
only
the
values

' Set sourceRange =
basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange
ref.
to

Regards alvin










Reply With QuoteReply With Quote
  #6   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 209
Default For the hard one -- myabe Tom??
Thanks its working with
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True

regards alvin


"Tom Ogilvy" skrev:

Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True

Turned the events off, turned them back on. If it worked before, it should
work now. (Unless you had an error in mybook.close True and it never
reached the line to turne them back on - in that case, run this code:)

Sub AllowEvents()
Application.EnableEvents = True
End Sub

--
Regards,
Tom Ogilvy


"Alvin Hansen" wrote in message
...
well then this doen't work
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub
When i try to update the sheet nothing happens it dosn't change the
picture
MAybe i shall give up on this?

regards alvin


"Tom Ogilvy" skrev:

Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the
' code below to copy only the values
' Set sourceRange = basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value
Application.EnableEvents = False
mybook.Close True
Application.EnableEvents = True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

is what I believe Ron is suggesting and it sounds good to me.

--
Regards,
Tom Ogilvy


"Ron de Bruin" wrote in message
...
Hi alvin

Disable the events

See the info on top of my page
http://www.rondebruin.nl/copy4.htm



--
Regards Ron de Bruin
http://www.rondebruin.nl



"Alvin Hansen" wrote in
message
...
Hi
I use this code :
Sub Copyrange1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "h:\city breaks\priser\usa\"
ChDrive MyPath
ChDir MyPath
FNames = Dir("fil.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

Set sourceRange = basebook.Worksheets("fil").Range("a1:c5")
Set destrange = mybook.Worksheets(1).Range("a1")
sourceRange.copy destrange
' Instead of this lines you can use the code below to copy
only
the
values

' Set sourceRange =
basebook.Worksheets(1).Range("a1:c5")
' Set destrange = mybook.Worksheets(1).Range("a1:c5")
' destrange.Value = sourceRange.Value

mybook.Close True
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

Its working aalright until i set this in to a sheet
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("a53")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

if i use thisthen i get an error on mybook.Close True
and the file stand open.

Hope some can help the code is not in the same sheet as Copyrange
ref.
to

Regards alvin











Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Too hard to do? LSSTOC Black Belt Charts and Charting in Excel 1 April 16th 10 11:27 PM
PLS, I need help, it is hard Attie Excel Worksheet Functions 6 August 11th 07 10:27 AM
Hard One. Chris S. Excel Discussion (Misc queries) 1 August 23rd 05 10:32 PM
Is this really hard? Jake Marx Excel Programming 1 September 19th 03 08:09 PM
Is this really hard? Dick Kusleika Excel Programming 2 September 18th 03 02:02 PM


All times are GMT +1. The time now is 06:08 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement