I am trying to import data from Excel into Access. Both 2010. Everything worked perfectly until I came across a cell that contained [text 'A' text]. Access completely stops the Sub at this point. When I manually change the Excel cell to [text A text] or the '' to ``, everything works perfectly again. But having to manually changing the source Excel defeats the purpose.
How do I import an Excel sheet when one or more cells contain [ 'A' ]?
Thank you in advance for any help.
'This checks if file exsist, imports file, then imports any sequential files.
Option Explicit
Public Sub ImportXL2(bolJustExcelFile As Boolean, Optional bolRefresh As Boolean)
Dim rstXL As DAO.Recordset
Dim x As Integer, y As Long
Dim strPath1 As String, strPath2 As String
Dim strPN As String, strDescription As String, strPrime As String
Dim intOHB As Integer, sngCost As Single, intMin As Integer, intMax As Integer
Dim strCode As Integer, strNumber As String, strDate As String, strQty As Integer, strRepairable As String, strEntity As String
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM ExcelFile"
If bolJustExcelFile = False Then
DoCmd.RunSQL "DELETE FROM ExcelFileCombined"
End If
For x = 1 To 10
DoCmd.RunSQL "DELETE FROM ExcelFiletemp"
strPath1 = Environ("userprofile") & "\Desktop\Folder\ExcelFile.xlsx"
strPath2 = Environ("userprofile") & "\Desktop\Folder\ExcelFile" & x & ".xlsx"
If x = 1 Then
If FileExists(strPath1) = -1 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "ExcelFiletemp", strPath1, False, "A:L"
Else
If bolRefresh = True Then
MsgBox "ExcelFile File Not Found", , "Missing ExcelFile File"
End If
Exit For
End If
Else
If FileExists(strPath2) = -1 And bolJustExcelFile = False Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "ExcelFiletemp", strPath2, False, "A:L"
Else
GoTo SkipXL
End If
End If
Set rstXL = CurrentDb.OpenRecordset("SELECT * FROM ExcelFiletemp", dbOpenSnapshot)
rstXL.MoveLast
rstXL.MoveFirst
For y = 1 To 4
rstXL.MoveNext
Next y
strEntity = Right(rstXL![F1], 6)
For y = 1 To 4
rstXL.MoveNext
Next y
On Error GoTo ErrHandler
For y = 1 To rstXL.RecordCount - 8
strPN = rstXL![F1]
strDescription = rstXL![F2]
strPrime = rstXL![F3]
intOHB = rstXL![F4]
sngCost = rstXL![F5]
intMin = rstXL![F6]
intMax = rstXL![F7]
strCode = rstXL![F8]
strRepairable = rstXL![F12]
If x = 1 Then
DoCmd.RunSQL "INSERT INTO ExcelFile (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & strPN & "','" & strDescription & "','" & strPrime & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & strRepairable & "','" & strEntity & "');"
End If
If bolJustExcelFile = False Then
DoCmd.RunSQL "INSERT INTO ExcelFileCombined (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & strPN & "','" & strDescription & "','" & strPrime & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & strRepairable & "','" & strEntity & "');"
End If
rstXL.MoveNext
Next y
rstXL.Close
SkipXL:
Next x
Set rstXL = Nothing
DoCmd.SetWarnings True
ErrHandler:
If Err.Number = 94 Then 'Invalid use of Null
rstXL.MoveNext
End If
End Sub
You can escape single quotes by doubling them up.
Function EscQ(text As String)
EscQ = Replace(text, "'", "''")
End Function
Usage:
DoCmd.RunSQL "INSERT INTO ExcelFileCombined (PN, Description, Prime, OHB, Cost, Min, Max, Code, Repairable, Entity) VALUES ('" & EscQ(strPN) & "','" & EscQ(strDescription) & "','" & EscQ(strPrime) & "'," & intOHB & "," & sngCost & "," & intMin & "," & intMax & "," & strCode & ",'" & EscQ(strRepairable) & "','" & EscQ(strEntity) & "');"
I think using recordset to add new record will somehow make you worry free about SQL Syntax getting wrong because of special characters e.g. single or double quotes. You can try add a function:
Function insrt_item(rstXL as DAO.Recordset, tbl_dest as String) ' set tbl_dest to ExcelFile or ExcelFileCombined since they are same fields anyway
With currentdb.OpenRecordSet(tbl_dest)
.AddNew
!PN = rstXL!F1
!Description = rstXL!F2
'.. add more fields here
.Update
.Close
End With
End Function
Related
I've written a function to loop through an array of a custom object (C_Document). In the loop, if the document number does not already exist, it should insert a new record into the table tbl_docs. If the document does exist, it should update the appropriate record in the database.
Public Function updateDocuments(docs() As C_Document) As Double
Dim db As Object
Set db = Application.CurrentDb
Dim docIndex As Double
'Loop through all imported documents
For docIndex = 1 To UBound(docs)
Dim strSQL As String
Dim exists As Double
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'" > 0)
'Check if entry already exists
If (exists > 0) Then
'docNo entry already exists - update
strSQL = "UPDATE tbl_docs SET " & _
"docReviewStatus = " & docs(docIndex).getDocStatus() & "," & _
"docRev = '" & docs(docIndex).getDocReview() & "'," & _
"docDate = '" & docs(docIndex).getDocDate() & "'" & _
" WHERE (" & _
"docNo = '" & docs(docIndex).getDocNo() & "');"
Else
'docNo does not exist - insert
strSQL = "INSERT INTO tbl_docs (docNo, docReviewStatus, docRev, docDate) " & _
"SELECT '" & docs(docIndex).getDocNo() & "'" & _
"," & docs(docIndex).getDocStatus() & _
",'" & docs(docIndex).getDocReview() & "'" & _
",'" & docs(docIndex).getDocDate() & "'" & _
";"
End If
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
MsgBox strSQL
Next
updateDocuments = docIndex
End Function
However, when the function is called (with tbl_docs empty), it only inserts one record and the SQL string thereafter becomes the update statement.
Is there a common issue when DCount() is used in a loop? Does anyone have any experience with this logical error?
Your check has a slight but important error:
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'" > 0)
should be
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'") > 0
or if exists isn't bool, but simply the count, then
exists = DCount("docNo", "tbl_docs", "docNo = '" & docs(docIndex).getDocNo() & "'")
You can simplify and speed up this a bit using DAO, where you can do the search and update/edit in one go:
Public Function updateDocuments(docs() As C_Document) As Long
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim docIndex As Long
Dim strSQL As String
strSQL = "Select * From tbl_docs"
Set db = Application.CurrentDb
Set rs = db.OpenRecordset(strSQL)
'Loop through all imported documents
For docIndex = LBound(docs) To UBound(docs)
rs.FindFirst "docNo = '" & docs(docIndex).getDocNo() & "'"
If rs.NoMatch Then
'docNo does not exist - insert
rs.AddNew
rs!docNo.Value = docs(docIndex).getDocNo()
Else
'docNo entry already exists - update
rs.Edit
End If
rs!docReviewStatus.Value = docs(docIndex).getDocStatus()
rs!docRev.Value = docs(docIndex).getDocReview()
rs!docDate = docs(docIndex).getDocDate()
rs.Update
Next
rs.Close
updateDocuments = docIndex
End Function
I want to loop through a folder and import all the files into Access.
This is my code:
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, MyFile, FileName, TextLine
Dim TextArray()
Dim x As Double
Dim SQLString
Set fso = CreateObject("Scripting.FileSystemObject")
FileName = "C:\Users\ava\Desktop\TEST_IMPORT\1.txt"
Set MyFile = fso.OpenTextFile(FileName, ForReading)
Do While MyFile.AtEndOfStream <> True
ReDim Preserve TextArray(x)
TextLine = MyFile.ReadLine
TextArray(x) = TextLine
x = x + 1
Loop
MyFile.Close
SQLString = "INSERT INTO TEST_TAB (Layout, Anzahl_Etiketten, Anzahl_Verpackungseinheiten, Bezeichnung1, Selektionsnummer, Bezeichnung2, Barcode, LA_Nummer, RM_Nummer, Bezeichnung3, Teilenummer) VALUES ('" & TextArray(0) & "','" & TextArray(1) & "','" & TextArray(4) & "','" & TextArray(5) & "','" & TextArray(6) & "','" & TextArray(7) & "','" & TextArray(9) & "','" & TextArray(10) & "','" & TextArray(13) & "','" & TextArray(15) & "','" & TextArray(19) & "');"
DoCmd.SetWarnings (WarningsOff)
DoCmd.RunSQL SQLString
DoCmd.SetWarnings (WarningsOn)
End Sub
The code imports a text file from my desktop (1.txt) then imports the data into my Access DB.
This works for my one File. (1.txt)
I found this link how to loop through a folder.
How do I implement that into my code?
im assuming you are reading every file with extension .txt in the folder C:\Users\ava\Desktop.
Try this...
Dim TextArray()
Dim x As Double
Dim SQLString
Set fso = CreateObject("Scripting.FileSystemObject")
strFolder= "C:\Users\ava\Desktop" 'sets folder
strFileName = Dir(strFolder & "\*.txt") 'grabs first txt file
Do While strFileName <> 0 'starts loop
FileName = strFileName 'set filename
Set MyFile = fso.OpenTextFile(FileName, ForReading)
'' Read from the file
Do While MyFile.AtEndOfStream <> True
ReDim Preserve TextArray(x)
TextLine = MyFile.ReadLine
TextArray(x) = TextLine
x = x + 1
Loop
MyFile.Close
SQLString = "INSERT INTO TEST_TAB (Layout, Anzahl_Etiketten, Anzahl_Verpackungseinheiten, Bezeichnung1, Selektionsnummer, Bezeichnung2, Barcode, LA_Nummer, RM_Nummer, Bezeichnung3, Teilenummer) VALUES ('" & TextArray(0) & "','" & TextArray(1) & "','" & TextArray(4) & "','" & TextArray(5) & "','" & TextArray(6) & "','" & TextArray(7) & "','" & TextArray(9) & "','" & TextArray(10) & "','" & TextArray(13) & "','" & TextArray(15) & "','" & TextArray(19) & "');"
DoCmd.SetWarnings (WarningsOff)
DoCmd.RunSQL SQLString
DoCmd.SetWarnings (WarningsOn)
strFileName = Dir 'Grabs next txt file
Loop
I'm not sure why you are using TextArray over and over and over, but consider doing it like this.
Option Compare Database
Private Sub Command0_Click()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Users\rschuell\Desktop\test\"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
strFile = Dir(strPath & "*.txt")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferText _
TransferType:=acImportDelim, _
TableName:=strTable, _
FileName:=strPathFile, _
HasFieldNames:=blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
strFile = Dir()
Loop
End Sub
I am facing a little issue now. My issue is that currently when i made edit to the current record in my subform and click on "update" it will overwrite my previous record which i do not want.
Instead, I would like to add my edited data record from the subform and insert it into the subform as a new record with the same PO number as the one that i am editing.
Below are my code:
Private Sub cmdAdd_Click()
'when we click on button Add there are two options
'1. for insert
'2. for update
If Me.txtID.Tag & "" = "" Then
'this is for insert new
'add data to table
CurrentDb.Execute "INSERT INTO mxd " & _
"(ID,Fabrication,Width,FinishedGoods,Colour, " & _
"LabDipCode,GrossWeight,NettWeight, " & _
"Lbs,Loss,Yds,Remarks,POType,ComboName,GroundColour)" & _
" VALUES(" & Me.txtID & ",'" & Me.txtFabrication & "','" & _
Me.txtWidth & "','" & Me.txtFinishedGood & "','" & _
Me.txtColour & "','" & Me.txtLabDipCode & "','" & _
Me.txtGrossweight & "','" & _ Me.txtNettweight & "','" & _
Me.txtLbs & "','" & Me.txtLoss & "','" & _ Me.txtYds & "','" & _
Me.txtRemarks & "','" & Me.cboPoType "','" & _
Me.txtGroundColour & "','" & Me.txtComboName & "')"
Else
'otherwise (Tag of txtID store the id of student to be modified)
CurrentDb.Execute "UPDATE mxd " & _
" SET ID = " & Me.txtID & _
", Fabrication = '" & Me.txtFabrication & "'" & _
", Width = '" & Me.txtWidth & "'" & _
", FinishedGoods = '" & Me.txtFinishedGood & "'" & _
", Colour = '" & Me.txtColour & "'" & _
", LabDipCode = '" & Me.txtLabDipCode & "'" & _
", GrossWeight = '" & Me.txtGrossweight & "'" & _
", NettWeight = '" & Me.txtNettweight & "'" & _
", LBS = '" & Me.txtLbs & "'" & _
", Loss = '" & Me.txtLoss & "'" & _
", Yds = '" & Me.txtYds & "'" & _
", Remarks = '" & Me.txtRemarks & "'" & _
", POType = '" & Me.cboPoType & "'" & _
", ComboName = '" & Me.txtComboName & "'" & _
", GroundColour = '" & Me.txtGroundColour & "'" & _
" WHERE ID = " & Me.txtID.Tag
End If
'clear form
cmdClear_Click
'refresh data in list on form
FormMxdSub.Form.Requery
End Sub
Private Sub cmdClear_Click()
Me.txtID = ""
Me.txtFabrication = ""
Me.txtWidth = ""
Me.txtFinishedGood = ""
Me.txtColour = ""
Me.txtLabDipCode = ""
Me.txtGrossweight = ""
Me.txtNettweight = ""
Me.txtLbs = ""
Me.txtLoss = ""
Me.txtYds = ""
Me.txtRemarks = ""
Me.cboPoType = ""
Me.txtKeywords = ""
Me.txtComboName = ""
Me.txtGroundColour = ""
'focus on ID text box
Me.txtID.SetFocus
'set button edit to enable
Me.cmdEdit.Enabled = True
'change caption of button add to Add
Me.cmdAdd.Caption = "Add"
'clear tag on txtID for reset new
Me.txtID.Tag = ""
End Sub
Private Sub cmdClose_Click()
DoCmd.Close
End Sub
Private Sub cmdDelete_Click()
'delete record
'check existing selected record
If Not (Me.FormMxdSub.Form.Recordset.EOF And
Me.FormMxdSub.Form.Recordset.BOF) Then
'confirm delete
If MsgBox("Are you sure you want to delete?", vbYesNo) = vbYes Then
'delete now
CurrentDb.Execute "DELETE FROM mxd " & _
"where ID = " & Me.FormMxdSub.Form.Recordset.Fields("ID")
'refresh data in list
Me.FormMxdSub.Form.Requery
End If
End If
End Sub
Private Sub cmdEdit_Click()
'check whether there is exists data in list
If Not (Me.FormMxdSub.Form.Recordset.EOF And
Me.FormMxdSub.Form.Recordset.BOF) Then
'get data to text box control
With Me.FormMxdSub.Form.Recordset
Me.txtID = .Fields("ID")
Me.txtFabrication = .Fields("Fabrication")
Me.txtWidth = .Fields("Width")
Me.txtFinishedGood = .Fields("FinishedGoods")
Me.txtColour = .Fields("Colour")
Me.txtLabDipCode = .Fields("LabDipCode")
Me.txtGrossweight = .Fields("GrossWeight")
Me.txtNettweight = .Fields("NettWeight")
Me.txtLbs = .Fields("Lbs")
Me.txtLoss = .Fields("Loss")
Me.txtYds = .Fields("Yds")
Me.txtRemarks = .Fields("Remarks")
Me.cboPoType = .Fields("POType")
Me.txtComboName = .Fields("ComboName")
Me.txtGroundColour = .Fields("GroundColour")
'store id of student in Tag of txtID in case id is modified
Me.txtID.Tag = .Fields("ID")
'change caption of button add to update
'Me.cmdAdd.Caption = "Update"
'disable button edit
Me.cmdEdit.Enabled = False
End With
End If
End Sub
You can use the RecordsetClone to create a dupe of the current record. Much faster and cleaner and no Tag is needed:
Private Sub btnCopy_Click()
Dim rstSource As DAO.Recordset
Dim rstInsert As DAO.Recordset
Dim fld As DAO.Field
If Me.NewRecord = True Then Exit Sub
Set rstInsert = Me.RecordsetClone
Set rstSource = rstInsert.Clone
With rstSource
If .RecordCount > 0 Then
' Go to the current record.
.Bookmark = Me.Bookmark
With rstInsert
.AddNew
For Each fld In rstSource.Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "SomeFieldToExclude" Then
' Leave field blank.
ElseIf .Name = "SomeOtherFieldToExclude" Then
' Leave field blank.
Else
' Copy field content.
rstInsert.Fields(.Name).Value = .Value
End If
End With
Next
.Update
' Go to the new record and sync form.
.MoveLast
Me.Bookmark = .Bookmark
.Close
End With
End If
.Close
End With
Set rstInsert = Nothing
Set rstSource = Nothing
End Sub
Of course, if you place the button on the main form, replace in the code Me with a reference to the subform: Me!NameOfYourSubformControl.Form
I'm writing VBA code for an application in Access for the first time and have created two separate strings to filter a report. The first of these strFilter filters the reports based on criteria in a list box. The second strWhere has been set up to filter the report based on a date input into a pair of text boxes. Both of these string filters work perfectly when used separately.
What I want to know is if there is a way to combine the two strings easily so that the user an filter the report based on both the criteria in the list box and the date they have entered in the text boxes.
The code I have for the listbox filter when it is added to the reports filter currently looks like this:
With Reports![rptFaultRecords]
.Filter = strFilter
.FilterOn = True
I want to add the string to filter by date strWhere next to the strFilter so the report can be filtered by both date and list criteria. All the code I've entered when attempting to do this has given me a run time error 3075. Is it possible for these two strings to be combined easily and if so how can I do it?
The rest of the code I've written is below if you need to see it:
Private Sub btnAllFaultsFilter_Click()
Dim varItem As Variant
Dim strRoom As String
Dim strFilter As String
Dim strDevice As String
Dim strCat As String
Dim strStatus As String
Dim strDateField As String
Dim strWhere As String
Const strcJetDate = "\#mm\/dd\/yyyy\#"
strDateField = "[f_datereported]"
If IsDate(Me.txtStartDate) Then
strWhere = "(" & strDateField & " >= " & Format(Me.txtStartDate, strcJetDate) & ")"
End If
If IsDate(Me.txtEndDate) Then
If strWhere <> vbNullString Then
strWhere = strWhere & " AND "
End If
strWhere = strWhere & "(" & strDateField & " < " & Format(Me.txtEndDate + 1, strcJetDate) & ")"
End If
For Each varItem In Me.lstRoom.ItemsSelected
strRoom = strRoom & ",'" & Me.lstRoom.ItemData(varItem) & "'"
Next varItem
If Len(strRoom) = 0 Then
strRoom = "Like '*'"
Else
strRoom = Right(strRoom, Len(strRoom) - 1)
strRoom = "IN(" & strRoom & ")"
End If
For Each varItem In Me.lstDevice.ItemsSelected
strDevice = strDevice & ",'" & Me.lstDevice.ItemData(varItem) & "'"
Next varItem
If Len(strDevice) = 0 Then
strDevice = "Like '*'"
Else
strDevice = Right(strDevice, Len(strDevice) - 1)
strDevice = "IN(" & strDevice & ")"
End If
For Each varItem In Me.lstCategory.ItemsSelected
strCat = strCat & ",'" & Me.lstCategory.ItemData(varItem) & "'"
Next varItem
If Len(strCat) = 0 Then
strCat = "Like '*'"
Else
strCat = Right(strCat, Len(strCat) - 1)
strCat = "IN(" & strCat & ")"
End If
For Each varItem In Me.lstStatus.ItemsSelected
strStatus = strStatus & ",'" & Me.lstStatus.ItemData(varItem) & "'"
Next varItem
If Len(strStatus) = 0 Then
strStatus = "Like '*'"
Else
strStatus = Right(strStatus, Len(strStatus) - 1)
strStatus = "IN(" & strStatus & ")"
End If
strFilter = "[c_roomid] " & strRoom & " AND [f_computername] " & strDevice & " AND [f_faultcategory] " & strCat & " AND [f_faultstatus] " & strStatus
With Reports![rptFaultRecords]
'.Filter = strFilter
.Filter = strFilter
.FilterOn = True
End With
End Sub
I need your help. I woulod like to change one char by another but in all database and i have several table and fields. So i'm building a function in VB but that change nothing and i have no error. I think that my condition is false but i don't see how to correct it :/
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
'check if String Data have my character
If InStr(1, fld.Name, Change) Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "], " & Change & ", " & replaced & ")"
db.Execute sSQL
End If
Next
Next
End Sub
EDIT :
I finally find what's wrong. if some people are interested :
Set db = CurrentDb
Change = "\"""
replaced = """"
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
sSQL = "UPDATE " & tbd.Name & " SET " & fld.Name & " = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "')"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
Thx for your help guys ;)
If it should help there my solution :
Public Sub updateField()
Dim db As DAO.Database, td As DAO.TableDef, field As DAO.field
Dim rs As DAO.Recordset, sSQL As String, sData As String, change As String, replace As String
change = "\'"
replace = "'"
' simple quote = 39
' doulbe quote = 34
' antislash = 92
' retour chariot = 13
' n = 110
' r = 114
Set db = CurrentDb
'each table in db
For Each tbd In db.TableDefs
'each field in table
For Each fld In tbd.Fields
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 4) <> "~TMP" Then
If fld.Type = dbText Or fld.Type = dbMemo Then
' \r\n
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\r\n','" & Chr(13) & Chr(10) & "');"
' \"
'sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'" & Chr(92) + Chr(34) & "','" & Chr(34) & "');"
'db.Execute sSQL
sSQL = "UPDATE " & tbd.Name & " SET [" & fld.Name & "] = replace([" & fld.Name & "],'\''','''');"
db.Execute sSQL
'Debug.Print (sSQL)
End If
End If
Next
Next
End Sub
That's works for me ;)