Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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.Worksh eets.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.Worksh eets.Count) sourceBk.Close savechanges:=False End If Next y End With Application.ScreenUpdating = True FName = Dir() Loop End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
I am still getting the same problem, i.e. an error with the following
lines:- sourceBk.Worksheets(y).Copy _ After:=wbMaster.Worksheets(wbMaster.Worksheets.Cou nt) 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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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? -- Regards, Nigel "tommo_blade" wrote in message ... I am still getting the same problem, i.e. an error with the following lines:- sourceBk.Worksheets(y).Copy _ After:=wbMaster.Worksheets(wbMaster.Worksheets.Cou nt) 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. |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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.Cou nt) puzzling.. |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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.workshe et.count) next wksSource -- HTH... Jim Thomlinson "tommo_blade" wrote: 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.Cou nt) puzzling.. |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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.Cou nt) cheers, Mark. |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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.Worksh eets.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 |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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" wrote in message ... 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.Worksh eets.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 |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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. |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
HELP= Problems Copying WorkBook Sheets
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 ---------------------------------------------------------------------- Many thanks. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Copying data from workbook/sheets to another workbook/sheet | Excel Programming | |||
COPYING Workbook and sheets automatically | Excel Discussion (Misc queries) | |||
Copying sheets to a new workbook | Excel Programming | |||
Copying Sheets to New Workbook | Excel Programming | |||
Copying Sheets to New Workbook | Excel Programming |