خطا در ایجاد کاربرگ جدید در اکسل توسط اکسس

[moustafa]

به جهت یکسان سازی نوع داده ها و جلوگیری از ورود اطلاعات تکراری با چندین شرط (چون نمیدونم چه فیلدی یونیکه با توجه به شرایط خودمون و عمومیت مسئله ) با اجازه تون من کدهای شما و خودمو تلفیق کردم (فعلاشروط کنترل اطلاعات تکراری رو تکی گذاشتم)

Private Sub btnBargozari_Click()

Dim dbs As DAO.Database

Dim td As DAO.TableDef

Dim fso As New FileSystemObject

If Nz(Me.txtFileName, "") = "" Then

    MsgBox ("áØÝÇ í˜ ÝÇíá ÇäÊÎÇÈ ˜äíÏ")

    Exit Sub

End If

If fso.FileExists(Nz(Me.txtFileName, "")) Then

    Set dbs = CurrentDb

    For Each td In dbs.TableDefs

        If td.Name = "tblEtelate_peymankariTemp" Then

           dbs.Execute "Drop Table tblEtelate_peymankariTemp;"

        End If

    Next

 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "tblEtelate_peymankariTemp", txtFileName, True

     



CurrentDb.TableDefs("tblEtelate_peymankariTemp").F  ields(0).Name = "f1"



DoCmd.RunSQL "DELETE * FROM tblEtelate_peymankariTemp WHERE (f4 =""ÝÕá"")"

Call ConvertField2

Dim rs1, rs As DAO.Recordset

        Dim k As Long

        Dim s, i As Integer

        k = Nz(DMax("ID", "tblEtelate_peymankari"), 0) + 1

        Set rs1 = CurrentDb.OpenRecordset("tblEtelate_peymankariTemp  ")

        Set rs = CurrentDb.OpenRecordset("Select * From tblEtelate_peymankari")

        DoCmd.SetWarnings False



        If Not (rs1.EOF And rs1.BOF) Then

        

            rs1.MoveFirst

            s = 0

            Do Until rs1.EOF = True

            If DCount("*", "tblEtelate_peymankari", "code_rojo='" & rs1!f2 & "'") = 0 Then

                rs.AddNew

                rs!Id = k

                 For i = 0 To rs1.Fields.Count - 1

                 If Not IsNull(rs1.Fields(i)) Then

                     rs.Fields(i + 1) = rs1.Fields(i)

                 End If

                 Next

            rs.Update

            s = s + 1

            k = k + 1

            End If

            rs1.MoveNext

            

            Loop

       MsgBox ("ÊÚÏÇÏ" & s & "јæÑÏ ÌÏíÏ Èå ÌÏæá ÓÝÇÑÔ  ÈÇ ãæÝíÊ ÇÖÇÝå ÔÏ")

        

        DoCmd.SetWarnings True



        End If



rs1.Clone

Set rs1 = Nothing

rs.Clone

Set rs = Nothing

   

   

dbs.Execute "Drop Table tblEtelate_peymankariTemp;"

    

   

Set dbs = Nothing



End If



End Sub

و برای تغییر دیتا تایپ و حذف کاما و اسلش

Public Sub ConvertField2()





On Error Resume Next

Dim rst As DAO.Recordset

Dim fld As DAO.Field

Set rst = CurrentDb.OpenRecordset("tblEtelate_peymankariTemp  ")

Do While Not rst.EOF

   rst.Edit

   For Each fld In rst.Fields

         

        If Not IsNull(fld) Then

         

           If fld.TypeIsNumeric Then

             fld = Replace(fld, ",", "")

             fld = Replace(fld, "/", "")

          End If

'

       End If

   Next

   rst.Update

   rst.MoveNext

Loop

rst.Close

Set rst = Nothing

End Sub