جابجائی سطر و ستون در جدول با حفظ مقادیر

[atf1379]

ضمن عرض سلام و تبریک سال نو خدمت تمام بزرگواران
در فایل ضمیمه جدولی وجود دارد که دارای 7 سطر و 7 ستون میباشد ، میخواهم در جدولی جدید جای سطرها و ستون ها با هم عوض شوند بطوریکه مقدار مربوط به هر سطر و ستون همچنان حفظ شود .
جدول جدید باید بصورت تصویر ضمیمه شود.
البته در تصویر کد و نام در کنار هم قرار گرفته اند که این دو میتوانند به تنهائی هم در عنوان ستون قرار بگیرند.
ممنون

[eb_1345]

ضمن عرض سلام و تبریک سال نو خدمت تمام بزرگواران
در فایل ضمیمه جدولی وجود دارد که دارای 7 سطر و 7 ستون میباشد ، میخواهم در جدولی جدید جای سطرها و ستون ها با هم عوض شوند بطوریکه مقدار مربوط به هر سطر و ستون همچنان حفظ شود .
جدول جدید باید بصورت تصویر ضمیمه شود.
البته در تصویر کد و نام در کنار هم قرار گرفته اند که این دو میتوانند به تنهائی هم در عنوان ستون قرار بگیرند.
ممنون
سلام
سال نو شما هم مبارک
قبل از حل مسئله باید اشاره کنم که بعضی از اعداد در تصویری که ضمیمه کرده اید اشتباه میباشد . مثلاً در جدول اعداد ستون 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

[atf1379]

سلام استاد !
بسیار بسیار عالی

احسنت !:تشویق::تشویق::تشویق: