مساعدة سريعة ارجوها منكم

[angelloay]

السلام عليكم ورحمة الله عندي مشكلة صغير ة وارجو من اخواني حلها

لدي صفحة اكسل موجودة لدي على جهاز اخر موصول مع الجهاز لي بشبكة اتصال محلية

المطلوب هو استيراد البيانات من الصفحة الموجودة على الجهاز الاخر الى صفحة اخرى موجودة على جهازي وبشرط ان نستطيع العمل على الصفحتين سويا

جربت الطريقة التالية:

قمت بربط صفحة الاكسل الاولى اللتي تحوي على بيانات بقاعدة بيانات اكسس

ثم قمت باسستيراد قاعدة البيانات من الصفحة الاخرى ونجحت الطريقة ولكن عندما اغير مسار قاعدة البيانات لا يستطيع الاكسل الموجود على جهازي التعرف على قاعدة البيانات ويطالبني مسار القاعدة الجديد وعندما احدده واضغط موافق تظهر الرسالة التالية

لم يتم العثور على قاعدة البيانات في المسار ((( المسار القديم لقاعدة البيانات)))

جربت اكثر من مرة ونفس المشكلة

وانا احتاجها بشكل ضروري جدا وارجوا منكم المساعدة و وشكرا سلفا

[طارق محمود]

السلام عليكم

مرحبا بك اخي الكريم

هل جربت تفعيل مشاركة الملف علي الشبكة الداخلية

أنظر الصورة المرفقة

[angelloay]

شكرا اخي الكريم على ردك نعم جربت الطريقة ولم تنجح بسبب انني لا اريد كافة البيانات الموجود بصفحة الاكسل الاخرى اريد فقط جدولين او ثلاثة ونجحت بربطها كما ذكرت سابقا ولكن مشكلة مسار قاعدة البيانات لم انجح بتغيره هل هناك حل اخر؟

وشكرا

[angelloay]

طريقة الاستخدام موضوعة من ANGELLLOAY

1- قم بفتح ملف الاكسل

2- قم بفتح محرر الفيجوال بيزك

3- قا بادراج موديلز جديد

4- اكتب الاوامر التالية في الموديلز الجديد

5- قم بتغير المسارات كالتالي:

OldPath = "C:\OldPath\Folder" المسار القديم = "محرك الاقراص التي كانت به قاعدة البيانات القديمة \ المسار القديم \ المجلد القديم

NewPath = "C:\NewPath\Folder" المسار القديم = "محرك الاقراص التي به قاعدة البيانات الجديدة \ المسار الجديد \ المجلد الجديد

:مع مراعاة انه عند وضع قاعدة البيانات داخل محرك اقراص بدون اي مجلد اكتب فقط اسم محرك الاقراص مثال

OldPath = "E:\"

NewPath = "D:\"

ثم قم بحفظ الموديلز من ايقونة الحفظ والاخرج من محرر الفيجوال بيزك ثم احفظ صفحة الاكسل وقم باغلاقها للضمان ثم قم بفتخها من جديد وجرب تحديث البيانات ومبروك عليك

Sub QueryChange()

Dim sh As Worksheet, qy As QueryTable

Dim pt As PivotTable, pc As PivotCache

Dim OldPath As String, NewPath As String

Dim rng As Range

'Replace the following paths with the original path or server name

'where your database resided, and the new path or server name where

'your database now resides.

OldPath = "C:\OldPath\Folder"

NewPath = "C:\NewPath\Folder"

For Each ws In ActiveWorkbook.Sheets

For Each qy In ws.QueryTables

qy.Connection = _

Application.Substitute(qy.Connection, _

OldPath, NewPath)

qy.CommandText = _

StringToArray(Application.Substitute(qy.CommandText, _

OldPath, NewPath))

qy.Refresh

Next qy

For Each pt In ws.PivotTables

pt.PivotCache.Connection = _

Application.Substitute(pt.PivotCache.Connection, _

OldPath, NewPath)

On Error Resume Next

pt.PivotCache.CommandText = _

StringToArray(Application.Substitute(pt.PivotCache.CommandText, _

OldPath, NewPath))

If Err.Number <> 0 Then

Err.Clear

On Error GoTo 0

Application.ScreenUpdating = False

Set rng = pt.TableRange2

pt.TableRange2.Copy Workbooks.Add(xlWorksheet).Worksheets(1) _

.Range("A1")

ActiveCell.PivotTable.PivotCache.CommandText = _

StringToArray(Application.Substitute(pt.PivotCache.CommandText, _

OldPath, NewPath))

ActiveCell.PivotTable.TableRange2.Copy pt.TableRange2

ActiveWorkbook.Close False

Set pt = rng.PivotTable

Application.ScreenUpdating = True

End If

pt.PivotCache.Refresh

Next pt

Next ws

End Sub

Function StringToArray(Query As String) As Variant

Const StrLen = 127

Dim NumElems As Integer

Dim Temp() As String

NumElems = (Len(Query) / StrLen) + 1

ReDim Temp(1 To NumElems) As String

For i = 1 To NumElems

Temp(i) = Mid(Query, ((i - 1) * StrLen) + 1, StrLen)

Next i

StringToArray = Temp

End Function