Printable View
ضمن عرض سلام و تبریک سال نو خدمت تمام بزرگواران
در فایل ضمیمه جدولی وجود دارد که دارای 7 سطر و 7 ستون میباشد ، میخواهم در جدولی جدید جای سطرها و ستون ها با هم عوض شوند بطوریکه مقدار مربوط به هر سطر و ستون همچنان حفظ شود .
جدول جدید باید بصورت تصویر ضمیمه شود.
البته در تصویر کد و نام در کنار هم قرار گرفته اند که این دو میتوانند به تنهائی هم در عنوان ستون قرار بگیرند.
ممنون
سلامنقل قول:
نوشته شده توسط atf1379
سال نو شما هم مبارک
قبل از حل مسئله باید اشاره کنم که بعضی از اعداد در تصویری که ضمیمه کرده اید اشتباه میباشد . مثلاً در جدول اعداد ستون A02 شامل 200 - 400 - 300 - 400 میباشد که در سطر جدول جدید باید همین اعداد درج شود در صورتیکه در سطر فوق در تصویر شما 2000- 400 - 400 -400 درج شده و همینطور بعضی ازاعداد ستون های A03 و A02 اشتباه میباشد .
و اما بپردازیم به حل مسئله:
قبل از هرچیز چند متغییر بصورت زیر تعریف و در قسمت ماژول عمومی فرم قرار میدهیم:
Dim dbs As DAO.Database, rst As DAO.Recordset, fld As DAO.Field, tdf As DAO.TableDef, Sql As String
در مرحله بعد باید اقدام به ایجاد یک جدول جدید و ایجاد یک فیلد(ستون ) در جدول فوق بکنیم
با کد های زیر یک جدول با نام Table2 و یک فیلد از نوع تکست با نام code ایجاد میشود:
Private Sub CreateTableAndField()
On Error Resume Next
Set dbs = CurrentDb
DoCmd.DeleteObject acTable, "Table2"
Set tdf = dbs.CreateTableDef("Table2")
Set fld = tdf.CreateField("code", dbText, 25)
tdf.Fields.Append fld
dbs.TableDefs.Append tdf
dbs.TableDefs.Refresh
Set dbs = Nothing
Set tdf = Nothing
Set fld = Nothing
End Sub
در ابتدای کدهای بالا قبل از ایجاد جدول جدید کد DoCmd.DeleteObject acTable, "Table2"
اضافه کرده ام که در هر بار جدول حذف و مجددً جدول و فیلد مربوطه ایجاد شود.
در مرحله بعد باید مقادیر کد یا ترکیب مقادیر کد و نام در جدول ایجاد شده جدید به ستون(فیلد) تبدیل شوند.
برای اینکار باید از کدهای زیر استفاده شود:
Sub CmdAddColumn()
Dim i As Integer
Dim StrCol As String
Set dbs = CurrentDb
Dim strSQL As String
Sql = "SELECT * FROM Table1 "
Set rst = dbs.OpenRecordset(Sql, dbOpenDynaset)
rst.MoveLast
rst.MoveFirst
For i = 1 To rst.RecordCount
If Check1 = False Then
StrCol = rst.Fields("code").Value
Else
StrCol = rst.Fields("code").Value & rst.Fields("namep").Value
End If
strSQL = "ALTER TABLE Table2 ADD COLUMN " & StrCol & " double"
DoCmd.RunSQL strSQL
rst.MoveNext
Next
rst.Close
Set dbs = Nothing
End Sub
در کدهای فوق این شرط را بکار برده ام که اگر چک باکس درج شده بر روی فرم تیک خورد از ترکیب کد و نام برای عنوان ستون ها استفاده شود و گرنه فقط از کد
و در مرحله آخر هم باید مقادیر عددی ستون های جدول قدیم به سطرهای جدول جدید اضافه شود . برای اینکار باید از کدهای زیر استفاده شود:
Private Sub CmdFillRow()
On Error Resume Next
Dim fcod As Long
Dim f As String
Dim ff As String
Dim ffF As Long
Dim rs As dao.Recordset
Dim fld As dao.Field
Set rs = CurrentDb.OpenRecordset("Table1", dbOpenDynaset)
Do Until rs.EOF
For Each fld In rs.Fields
If fld.Name <> "code" And fld.Name <> "namep" Then
f = fld.Name
End If
If fld.Name = "code" Then
fcod = fld.Value
If Check1 = False Then
ff = fcod
Else
ff = fcod & "_" & DLookup("namep", "Table1", "code=" & fcod & "")
End If
End If
If fld.Name <> "code" And fld.Name <> "namep" Then
ffF = fld.Value
End If
DoCmd.RunSQL "Update Table2 Set Table2." & ff & " = " & ffF & " where (code='" & f & "')"
Next
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
End Sub
سلام استاد !
بسیار بسیار عالی
احسنت !:تشویق::تشویق::تشویق: