Copying Sheets to a woekbook

  • Thread starter Thread starter bbibee
  • Start date Start date
B

bbibee

Is there a method for copying sheets from a workbook that is not open to a
workbook that is? I have written a vba that lets a user select a number of
workbooks (.FindFile method) that will open them, copy the tab (worksheet) of
each workbook to the end of the target workbook, rename the new tab to the
name of the file it came from, and then close the workbook. It would go a
lot faster if I could get the tab from the workbook without opening it.
 
Thanks Joel- I need to digest what you presented and see which lines are
pertinent to my situation.

joel said:
Since the file structure of all office products are the same you can get
data from an excel spreadsheet just like you would an Access Database.
do a search for ADO method Excel.

There are some slight differences in naming conventions. the ADO
method requires you do put a dollar sign at the end of each sheet name.

Below is code I wrote for somebody a couple of months ago. the code
create a SQL string to get the data and it even filters the sheet using
a person name. You can leave off the persons name in the SQL.




Sub MoveData()

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Set sourcesht = ThisWorkbook.Sheets("Sheet1")
Folder = "c:\Temp\"
DestFile = Folder & "Activity overview1.xls"
'excel worksheet must have dollar sign at end of name
DestShtName = "Sheet1" & "$"

With sourcesht
Person = .Range("A1")
EstWorkLoad = .Range("C4")
RealWorkLoad = .Range("C5")
WeekNum = .Range("F2")
End With

'open a connection, doesn't open the file
Set cn = New ADODB.Connection

With cn

ConnectStr = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DestFile & ";" & _
"Mode=Share Deny None;" & _
"Extended Properties=""Excel 8.0;HDR=No;ReadOnly=False;"""

.Open (ConnectStr)
End With

'open the recordset
Set rs = New ADODB.Recordset
With rs

MySQL = "SELECT * FROM [" & DestShtName & "] "

.Open Source:=MySQL, _
ActiveConnection:=cn

If .EOF <> True Then

RowCount = 1
Do While Not .EOF And RowCount < 14

.MoveNext
RowCount = RowCount + 1
Loop

If .EOF Then
MsgBox ("Not Enough Rows - Exit macro")
End If

setLoad = ""

WorkWeekCol = 0
WorkWeek = 22
For Each Fld In rs.Fields
If Fld.Value = WorkWeek Then
'rows and columns are backwards from excel
WorkWeekCol = Range(Fld.Name).Row
Exit For
End If
Next Fld
End If

If WorkWeekCol = 0 Then
MsgBox ("Did not find WorkWeek : " & WorkWeek & ". Exiting
Macro")
Exit Sub
End If

.Close

Person = "Joel"

MySQL = "SELECT *" & vbCrLf & _
"FROM [" & DestShtName & "] " & vbCrLf & _
"Where [" & DestShtName & ".F1]='" & Person & "'"

.Open Source:=MySQL, _
ActiveConnection:=cn, _
LockType:=adLockOptimistic, _
CursorType:=adCmdTable

If .EOF = True Then
MsgBox ("count not find : " & Person & " Exit Macro")
Exit Sub
Else

EstWorkLoad = 123
RealWorkLoad = 456
'field start at zero, subtract one from index
.Fields(WorkWeekCol - 1).Value = EstWorkLoad
.Fields(WorkWeekCol).Value = RealWorkLoad
.Update
End If


End With

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=174932

Microsoft Office Help

.
Click to expand...
 
Back
Top