Posted at Copy cells in every closed worksheets instead of first worksheet to new workbook - Page 2
error :
I provided link for the forum i posted in, i got Run time error 5 : Invalid procedure call or arguement at above code. Need help to solve it, thank you.
Code:
For N = LBound(FName) To UBound(FName)
sFName = FName(N)
Set SheetNum = FunctionModule.GetSheetsName(sFName)
For i = 1 To SheetNum.Count
' Find the last row with data
rnum = LastRow(sh)
' Set Column A for item name
Set destrangeName = sh.Cells(rnum + 1, "A")
' Set Column B for article number
Set destrangeArticle = sh.Cells(rnum + 1, "B")
' Set Column C for start date
Set destrangeStart = sh.Cells(rnum + 1, "C")
' Set Column D for end date
Set destrangeEnd = sh.Cells(rnum + 1, "D")
' Set Column E for promo price
Set destrangePrice = sh.Cells(rnum + 1, "E")
' Copy item name from other worksheets and insert into current worksheet
GetData sFName, SheetNum(i), ws.Range("A2"), destrangeName, False, False
' Copy article number from other worksheets and insert into current worksheet
GetData sFName, SheetNum(i), ws.Range("B2"), destrangeArticle, False, False
' Copy start date from other worksheets and insert into current worksheet
GetData sFName, SheetNum(i), ws.Range("C2"), destrangeStart, False, False
' Copy end date from other worksheets and insert into current worksheet
GetData sFName, SheetNum(i), ws.Range("D2"), destrangeEnd, False, False
' Copy promo price from other worksheets and insert into current worksheet
GetData sFName, SheetNum(i), ws.Range("E2"), destrangePrice, False, False
Next i
Next N
Code:
Function GetSheetsName(xFile As String) As Collection 'Codes Found online with modifications made
'Needs a reference to:
'Microsoft ActiveX Data Object X.X Library
'Microsoft ADO Ext. X.X for DLL and Security
Dim objConn As Object
Dim objCat As Object
Dim tbl As Object
Dim sConnString As String
Dim sSheet As String
Dim Col As New Collection
If Val(Application.Version) < 12 Then
sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & xFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
sConnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & xFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Set objConn = CreateObject("ADODB.Connection")
objConn.Open sConnString
Set objCat = CreateObject("ADOX.Catalog")
Set tbl = CreateObject("ADOX.Table")
Set objCat.ActiveConnection = objConn
For Each tbl In objCat.Tables
sSheet = tbl.Name
sSheet = Application.Substitute(sSheet, "'", "")
sSheet = Left(sSheet, InStr(1, sSheet, "$", 1) - 1)
On Error Resume Next
Col.Add sSheet, sSheet
On Error GoTo 0
Next tbl
Set GetSheetsName = Col
objConn.Close
Set objCat = Nothing
Set objConn = Nothing
End Function
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error Resume Next
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Functionerror :
Code:
sSheet = Left(sSheet, InStr(1, sSheet, "$", 1) - 1)I provided link for the forum i posted in, i got Run time error 5 : Invalid procedure call or arguement at above code. Need help to solve it, thank you.
