السلام عليكم ورحمة الله وبركاته ..... جميع اعضاء المنتدى ..... كل عام وانتم بخير وأسأل الله عز وجل أن يتقبل منا ومنكم صالح الاعمال
استفسار حول كود سابق شارك في موضوعة في هذا الموضوع الأساتذة :
@فايز و @Barna و @jjafferr و @أبو إبراهيم الغامدي في هذا الموضوع ولدي عدد من الاستفسار على الكود التالي بارك الله فيكم :
Option Compare Database
Option Explicit
Sub IMPORT_XLSDB()
On Error GoTo SUB_CLOSE
'-- OPEN CURRENT DATABASE AS LOCAL DB
Dim DB As DAO.Database
Set DB = CurrentDb
'-- OPEN RS DB TO ADD DATA
Dim DBRS As DAO.Recordset
Set DBRS = CurrentDb.OpenRecordset("TABLE")
'-- OPEN XLS FILE AS REMOTE DATABASE
Dim XLDB As DAO.Database
Set XLDB = OpenDatabase( _
CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;")
'-- OPEN XLS SHEET AS REMOTE RS
Dim XLRS As DAO.Recordset
Dim RCROW()
Dim RC As Long
Dim I As Integer
Dim TD As DAO.TableDef
'-- LOOP THROUGH XLDB TABLES (SHEETS)
For Each TD In XLDB.TableDefs
'-----------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (C) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
DBRS![ACADEMIC YEAR] = RCROW(0, 0)
DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
DBRS![STNAME] = RCROW(0, 2)
DBRS![F1] = RCROW(0, 3)
DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
'--------------------------------------------------------------------------------------'
'-- RECORDS FROM COLUMN (I) IN XL SHEET
Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)")
'-- COUNT RECORDS
XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst
'-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS
For I = 1 To RC Step 5
RCROW = XLRS.GetRows(5)
DBRS.AddNew
DBRS![ACADEMIC YEAR] = RCROW(0, 0)
DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32)))
DBRS![STNAME] = RCROW(0, 2)
DBRS![F1] = RCROW(0, 3)
DBRS![Sub] = RCROW(0, 4)
DBRS.Update
Next
Set XLRS = Nothing
Next
SUB_CLOSE:
'-- COLOSE XLDB AND XLRS
Set XLRS = Nothing
' XLDB.Close
Set XLDB = Nothing
'------------------------'
'-- CLOSE DB AND DBRS
Set DBRS = Nothing
XLDB.Close
Set XLDB = Nothing
End Sub
1- ما المقصود في الاؤقام المسجلة في 1 و 2
2- ما المقصود ب F1 و هل يمكن تغيير النطاق في 4 وكيف يتم ذلك لو اغترضنا أن ملف الاكسل نريد جلب بيانات اكثر من عامود في الصفحة الواحدة دون تكرار للكود كما فعلنا في الكود السابق بمعنى بجلب بيانات العمود C والعمود I مباشرة أو حتى أكثر من عمودين ؟؟؟؟
بارك الله فيكم وفي علمكم ...
الموضوع هنا بارك الله فيكم