عاجل: أريد كود لاستيراد بيانات من شيتين في ملف آخر

[خالدو]

السلام عليكم ورحمة الله وبركاته

إخواني أحتاج انجاز هذا الملف بشكل عاجل فقد حاولت فيه ولكنني فشلت ودائماً بفضل الله أجد عندكم الحلول:

المطلوب استيراد بيانات من ملف اسمه Source إلى ملف آخر اسمه Report

Source

فيه صفحتين الأولى عبارة عن تبويب للثانية والخلاصة أو الملخص يتم تصديره

الخلاصة :

إني افتح ملف Report واكبس الزر يتم استيراد البيانات من ملف Source بشرط وجوده طبعاً

وجزاكم الله خيراً

jg.zip

[خالدو]

السلام عليكم ورحمة الله وبركاته

يوجد لدي محاولة ولكن ملف التقرير جعلت فيه شيت للمصدر ولكن المشكلة إنه بطيء جداً فهل من الممكن المساعدة في تسريع القيد وجعله أكثر كفائة وضغطه لأقصى حد ممكن؟

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

وجزاكم الله خيراً

الكود:

Private Sub CommandButton2_Click()

On Error Resume Next

If CommandButton2.Caption = "ImportData" Then

khaledo = MsgBox("Would you like to update source links before proceeding?", vbYesNo, " Reporting Sys-BTC")

If khaledo = vbYes <> "" Then ThisWorkbook.UpdateLink ("C:\Source\source.xls")

Select Case CommandButton2.Caption

Case Is = "ImportData"

Call Khaledo1

CommandButton2.Caption = "ClearData"

Case Is = "ClearData"

Call khaledo2

CommandButton2.Caption = "ImportData"

End Select

If khaledo = vbNo Then

Select Case CommandButton2.Caption

Case Is = "ImportData"

Call Khaledo1

CommandButton2.Caption = "ClearData"

Case Is = "ClearData"

Call khaledo2

CommandButton2.Caption = "ImportData"

End Select

End If

End If

End Sub

Sub Khaledo1()

Sheets("SAPBW70_DOWNLOAD").Select

Application.EnableEvents = False

Application.ScreenUpdating = False

Dim i

If Range("S8") = "" Then

For i = 7 To 1250

With Range("r7")

.Formula = "=VLookup(b7,'GL Mapping'!$c:$e,3,False)"

With .Resize(Range("r" & i).End(xlUp).Row)

.FillDown

.Copy

.PasteSpecial xlPasteValues

End With

End With

Next

End If

If Range("S8") = "" Then

Range("r8:r1250").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("s8"), Unique:=True

Range("S8").ClearContents

End If

Dim ddd

For ddd = 8 To 200

With Range("t9")

.Formula = "=SUMIF($R$7:$R$1250,$S9,$e$7:$e$1250)"

With .Resize(Range("t" & ddd).End(xlUp).Row - 1)

.FillDown

.Copy

.PasteSpecial xlPasteValues

End With

End With

Next

Dim CC

For CC = 8 To 200

With Range("u9")

.Formula = "=SUMIF($R$7:$R$1250,$S9,$f$7:$f$1250)"

With .Resize(Range("u" & CC).End(xlUp).Row - 1)

.FillDown

.Copy

.PasteSpecial xlPasteValues

End With

End With

Next

Dim EE

For EE = 8 To 200

With Range("v9")

.Formula = "=SUMIF($R$7:$R$1250,$S9,$g$7:$g$1250)"

With .Resize(Range("V" & EE).End(xlUp).Row - 1)

.FillDown

.Copy

.PasteSpecial xlPasteValues

End With

End With

Next

Application.EnableEvents = True

Application.ScreenUpdating = True

Range("c1").ClearContents

'Range("a1").Select

Sheets("FS 2012 new").Select

End Sub

Sub khaledo2()

Sheets("SAPBW70_DOWNLOAD").Select

Range("R8:AE1250").ClearContents

Range("A1").Select

Sheets("FS 2012 new").Select

[طارق محمود]

السلام عليكم

أخي الكريم

تفضل المرفق

إضغط الزر الأحمر

jg.rar

[خالدو]

أخي واستاذي الحبيب طارق

جزاك الله خيراً على اهتمامك وعلى وقتك

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

هل من الممكن ان يتم الربط والتحديث والمصدر مغلق

ولو ممكن تكمل جميلك معي تتكرم وتحل لي المطلوب في الملف المرفق.

وجزاك الله خيراً أخي الحبيب

Copy of Source.zip