HELP=> Problems Copying WorkBook Sheets

[tommo_blade]

Hi,
I have started a new thread on this problem, my other thread got
a little lost and I was not getting the right answers. Basically I
need to copy sheets from 'n' different closed workbooks into my open
workbook from where the macro is being executed, this new sheet needs
to be the last sheet in my workbook, here is the copying code I am
using:

sourceBk.Worksheets(y).Copy _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

The source file (closed workbooks) is ok, it reads this fine, what I
cannot work out is how to reference my open workbook, the code above
does not work, I have also tried using 'ActiveWorkbook' but it does
not like this either. the full code I am using is shown below.

Sub import_xls()
Dim y As Integer
Dim d As Integer
Dim p As Integer


Folder = "F:\My Documents\Fantasy Football\XLS_Emails\"
FName = Dir(Folder & "*.xls")
Application.ScreenUpdating = False
Do While FName <> ""
d = 0
With ThisWorkbook
Set sourceBk = Workbooks.Open(Filename:=Folder & FName)
For y = 1 To sourceBk.Worksheets.Count
If Left(sourceBk.Worksheets(y).Cells(1, 1), 4) = "Name" Then
d = d + 1
MsgBox "FOUND A VALID TEAMSHEET " &
sourceBk.Worksheets(y).Cells(1, 2) & " IN:" & FName
For p = 8 To 18
If InStr(1, sourceBk.Worksheets(y).Cells(p, 2), 1) <> "" Then
'MsgBox "PLAYER CELL POPULATED OK: " & p
Else
MsgBox "ERROR: EMPTY PLAYER CELL IN: " &
sourceBk.Workheets(y).Cells(p, 2)
Exit Sub
End If
Next p

Else
'MsgBox "UN-MATCHED TEAMSHEET:" & FName
End If

If d = 1 Then
MsgBox "CREATING NEW WORKSHEET FOR: " &
sourceBk.Worksheets(y).Cells(1, 2)

sourceBk.Worksheets(y).Copy _

After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
sourceBk.Close savechanges:=False

End If
Next y
End With
Application.ScreenUpdating = True

FName = Dir()
Loop
End Sub

 

[Nigel]

Set a reference to your workbook before you start and use that....

Dim wbMaster as Workbook
Set wbMaster = ActiveWorkbook

Use wbMaster as your reference

 

[tommo_blade]

I am still getting the same problem, i.e. an error with the following
lines:-

sourceBk.Worksheets(y).Copy _
After:=wbMaster.Worksheets(wbMaster.Worksheets.Count)

I have added the code at the very top to set 'wbMaster' as you stated,
so:-

Sub import_xls()
Dim y As Integer
Dim d As Integer
Dim p As Integer
Dim c As Integer
Dim wbMaster As Workbook

Set wbMaster = ActiveWorkbook
Folder = "F:\My Documents\Fantasy Football\XLS_Emails\"
FName = Dir(Folder & "*.xls")
Application.ScreenUpdating = False

<< MORE CODE HERE >>



thanks in advance for any assistance, Mark.

 

[Nigel]

Your code should work, and works for me. But only if var Y has a valid index
number for a sheet in the sourceBk.

Have you checked this value?

 

[tommo_blade]

It does, I printed the value of 'y' just prior to the copy statemet
and this was '6' which is exactly the sheet I need in the source
workbook, you can also see in my code another print statement just
prior to the 'Copy' function - this prints the value of a cell (1,2)
in that sheet and also returns the correct data:-

MsgBox "CREATING NEW WORKSHEET FOR: " &
sourceBk.Worksheets(y).Cells(1, 2)
MsgBox "Y: " & y
sourceBk.Worksheets(y).Copy _
After:=wbMaster.Worksheets(wbMaster.Worksheets.Count)

puzzling..

 

[Jim Thomlinson]

Your original code using thisworkbook was correct. There is no need to create
an object varaible. Thisworkbook is always the workbook where the code is
running from.
There is nothing specificly wrong with the line of code that you have. What
error are you getting. If it is subscript out of range then I would suggest
that you are trying to reference a worksheet that does not exist.

I am curious why you are using y for a variable instead of using a worksheet
object?
Change
For y = 1 To sourceBk.Worksheets.Count
using index numbers is very difficult to debug...
to

dim wksSource as worksheet
for each wksSourse in sourceBk.Worksheets
'your code directly referenceing the worksheet
wksSource.copy After:=ThisWorkbook.worksheet(thisworkbook.worksheet.count)
next wksSource

 

[tommo_blade]

I will give your worksheet object suggestion a try and report back, to
answer your question about the error, I do not get any specific error
pop up, it is more the code stops running and the vb editor opens with
the code highlighted in yellow - I thought this pointed to an error
but I am starting to wonder now, any suggestions ?

the code it highlights is:-

sourceBk.Worksheets(y).Copy _
After:=wbMaster.Worksheets(wbMaster.Worksheets.Count)


cheers, Mark.

 

[tommo_blade]

I have implemented all of your suggestions but there is still a
problem, the code does not like the 'wksSource' statement, even when I
try and print it directly after the 'for each wksSource' line, it does
not give an error - it simply stops the program running, opens the VB
editor and highlights the problem lines in yellow, see below:


Sub import_xls()
Dim y As Integer
Dim d As Integer
Dim p As Integer
Dim c As Integer
Dim wksSource As Worksheet

Folder = "F:\My Documents\Fantasy Football\XLS_Emails\"
FName = Dir(Folder & "*.xls")
Application.ScreenUpdating = False
Do While FName <> ""
d = 0
With ThisWorkbook
Set sourceBk = Workbooks.Open(Filename:=Folder & FName)
For Each wksSource In sourceBk.Worksheets
MsgBox "TEAMSHEET: " & wksSource <---------------------------
DOES NOT LIKE THE 'wksSource'
If Left(wksSource.Cells(1, 1), 4) = "Name" Then
d = d + 1
MsgBox "FOUND A TEAMSHEET " & wksSource.Cells(1, 2) & " IN: "
& FName
For p = 8 To 18
If InStr(1, wksSource.Cells(p, 2), 1) <> "" Then
'MsgBox "PLAYER CELL POPULATED OK: " & p
Else
MsgBox "ERROR: EMPTY PLAYER CELL IN: " &
wksSource.Cells(p, 2)
Exit Sub
End If
Next p

Else
MsgBox "UN-MATCHED TEAMSHEET:" & wksSource
End If

If d = 1 Then
MsgBox "CREATING NEW WORKSHEET FOR: " & wksSource & "#" &
wksSource.Cells(1, 2) <--------------------------- DOES NOT LIKE
THE 'wksSource'
wksSource.Copy
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
<--------------------------- DOES NOT LIKE THE 'wksSource'
sourceBk.Close savechanges:=True
ElseIf d > 1 Then
MsgBox "WORKBOOK CONTAINS TOO MANY SHEETS: "
End If
Next wksSource
End With
Application.ScreenUpdating = True

FName = Dir()
Loop
End Sub

 

[Rick Rothstein \(MVP - VB\)]

MsgBox "TEAMSHEET: " & wksSource

MsgBox "CREATING NEW WORKSHEET FOR: " &
wksSource & "#" & wksSource.Cells(1, 2)

I am pretty sure that for the above two MessageBox statements, the problem
is with your trying to concatenate wksSource (an object) as if it were a
String value. I that these two statements should work correctly if you use
wksSource.Name instead of wksSource by itself. On the other hand, and I may
be missing something obvious here, but I don't see anything immediate wrong
with this statement...

wksSource.Copy After:=ThisWorkbook.Worksheets(
ThisWorkbook.Worksheets.Count)

Let's take this in steps. Correct the first two problems listed above and
run your code.... does it still have problems elsewhere, or is this Copy now
the only problem?

Rick

 

[tommo_blade]

thanks, that has fixed the problem, I misunderstood what the code was
doing when I was told to use that method, I'm new to VB so my
apologies.

 

[tommo_blade]

Hello, you were a big help to me with some VB code I had an issue
with, could you help me again if you have the time, I have one last
remaining issue that I cannot work out for myself.

I have imported a worksheet into my workbook, this worksheet has some
VB code behind it, in my workbook I then run a macro that will update
this imported worksheet, it is when I try to update the worksheet that
an error is thrown up, the error is shown below:

Run-time error '1004':
Application-defined or object-defined error

The VB in the imported worksheet has some code that sets the colour of
the cell depending on the cell value, the macro that I run from within
the workbook is putting a value into these cells and I am wanting the
imported worksheet VB code to then change the cell colour dependant
upon the data I put into these cells, the problem is that it throws
the above error. I have put the 2 pieces of code below, the direst is
the VB in the imported worksheet, the line with the '==> <==' is the
line that is failing, the 2nd piece of code is the macro that is run.


Imported wprksheet VB code
----------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim TeamCount As Integer

Dim myCols(12)
myCols(1) = "5"
myCols(2) = "7"
myCols(3) = "9"
myCols(4) = "11"
myCols(5) = "13"
myCols(6) = "15"
myCols(7) = "17"
myCols(8) = "19"
myCols(9) = "21"
myCols(10) = "23"
myCols(11) = "25"
myCols(12) = "27"


For i = 1 To 12
If Target.Column = myCols(i) Then
InputValue = Target.Value

If InputValue = "N" Then
==> Target.Interior.ColorIndex = 3 <==
ElseIf InputValue > 0 Then
Target.Interior.ColorIndex = 38
Else
Target.Interior.ColorIndex = white
End If
End If
Next i


If Target.Column = 3 Then
For x = 8 To 18
TeamCount = 0
For y = 8 To 18
If Target.Worksheet.Cells(x, 3) =
Target.Worksheet.Cells(y, 3) And Target.Worksheet.Cells(x, 3) <> ""
Then
TeamCount = TeamCount + 1
End If
Next y

If TeamCount > 2 Then
Target.Worksheet.Cells(x, 3).Interior.ColorIndex = 3
Else
Target.Worksheet.Cells(x, 3).Interior.ColorIndex = 0
End If
Next x
End If

End Sub




2nd piece of code - workbook macro
---------------------------------------------------------------
Sub ControlSheet_UpdateTeamsBtn_Click()

Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim w As Integer
Dim acol As Integer
Dim dcol As Integer
Dim player As String
Dim club As String
Dim position As String
Dim iReply As Integer
Dim pos As String
Dim pos_col As Integer
Dim wks As Worksheet


On Error GoTo canceled
iReply = InputBox(Prompt:="Enter The Week (1-6):", _
Title:="UPDATE TEAMSHEETS", Default:="0")

If iReply = 0 Then
MsgBox "YOU DID NOT ENTER A VALID WEEK NUMBER (1-6 Only)"
Exit Sub
End If
If iReply = 1 Then
acol = 5
dcol = 17
'MsgBox "Week1 - Column 5"
ElseIf iReply = 2 Then
acol = 7
dcol = 19
'MsgBox "Week2 - Column 7"
ElseIf iReply = 3 Then
acol = 9
dcol = 21
'MsgBox "Week3 - Column 9"
ElseIf iReply = 4 Then
acol = 11
dcol = 23
'MsgBox "Week4 - Column 11"
ElseIf iReply = 5 Then
acol = 13
dcol = 25
'MsgBox "Week5 - Column 13"
ElseIf iReply = 6 Then
acol = 15
dcol = 27
'MsgBox "Week6 - Column 15"
End If

For z = 1 To 1000
If ActiveSheet.Cells(z, 1).Value <> "" Then
MyData = Split(ActiveSheet.Cells(z, 1).Value, ":")
player = MyData(2)
club = MyData(1)
position = MyData(0)
If ActiveSheet.Cells(z, 2).Value <> "N" Then
goals_scored = ActiveSheet.Cells(z, 2)
clean_sheet = ActiveSheet.Cells(z, 3)
'MsgBox "MATCH DATA FOUND:" & player & "#GOAL SCORED:" &
goals_scored & "#CLEAN SHEET:" & clean_sheet
For Each wks In ThisWorkbook.Worksheets
If Left(wks.Name, 2) = "FF" Then
'MsgBox "WORKSHEET: " & wks.Name & "<-->Looking for
PLAYER:" & player
Set f = wks.Columns("B").Find(what:=player,
LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
'MsgBox player & " FOUND IN ROW: " & f.row & ",
UPDATING DATA: " & goals_scored
pos = wks.Cells(f.row, 1)
'MsgBox "THIS PLAYER IS A:" & pos
If wks.Cells(f.row, acol).Value <> "N" Then
'MsgBox "SCORES ALREADY UPDATED FOR WEEK: " &
iReply
Exit Sub
End If
'MsgBox "1.MODIFY CELL: " & f.row & "#" & acol
wks.Cells(f.row, acol) = goals_scored
If Left(pos, 2) = "GK" Then
wks.Cells(f.row, dcol) = clean_sheet
ElseIf Left(pos, 3) = "DEF" Then
wks.Cells(f.row, dcol) = clean_sheet
End If
Else
'MsgBox player & " NOT FOUND ON WORKSHEET:" &
wks.Name
End If
Else
'MsgBox "NOT FF TEAMSHEET:" & wks.Name
End If

Next wks
End If
End If
Next z


canceled:
End Sub