طريقة الاستخدام موضوعة من 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
