ترحيل بيانات بين ملفين

[يوسف السيد]

السلام عليكم :

عندى ملف اكسل اسمة " تحليل بيانات" وبه الخليه A4 تحدد رقم الشهر 1,2,3 إلخ .....
وايضا ملف اكسل اسمة "بيانات شهرية" والشيتات فيه عبارة عن رقم الاشهر  1,2,3 إلخ .....

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

الترحيل.rar

تم تعديل أغسطس 28, 2013 بواسطه يوسف السيد

[الـعيدروس]

الصق الكود التالي في مودويل

في ملف تحليل البيانات

على ان يكونو الملفين في فولدر واحد

Private Const Nm As String = "بيانات شهرية.xlsm"
Private Const Adr As String = "$A$4"
Public Sub Ali_Tr()
Dim Wb As Workbook
Dim Wbc As Workbook
Dim W As Worksheet
Dim De$, Pth$
N = ThisWorkbook.Name
Set Wbc = Workbooks(N)
Pth = ThisWorkbook.Path & "\" & Nm
If Not Is_Opn(Pth) Then
 Workbooks.Open Pth
End If
Set Wb = Workbooks(Nm)
For Each W In Wb.Worksheets
 If W.Name = Wbc.Worksheets(1).Range(Adr).Text Then
  De = W.Name
  Exit For
 End If
Next
Wbc.Activate
Application.EnableEvents = False
With Wb.Worksheets(De)
With Wbc
Lr = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
 .Activate
 .Sheets(1).Range(.Sheets(1).Cells(6, 1), .Sheets(1).Cells(Lr, 3)).Copy
End With
  L = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 .Range("A" & L).PasteSpecial xlPasteValues
Application.CutCopyMode = False
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, ""
End With
End Sub
Function Is_Opn(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
    Select Case iErr
    Case 0:    Is_Opn = False
    Case 70:   Is_Opn = True
    Case Else: Error iErr
    End Select
End Function

الترحيل_A.rar

تم تعديل أغسطس 29, 2013 بواسطه عباد

[يوسف السيد]

الاستاذ : عباد ... الكود جميل جداً وينفذ المطلوب
بارك الله لك ورزقك من حيث لا تدرى
شكراً جزيلاً ... اخى الفاضل

[الـعيدروس]

الحمد الله الذي بنعمته تتم الصالحات

------------------------------------

اخي يوسف السيد الشكر لله نحنو بالخدمه اخي الكريم

مادام الطلب في حدود المعرفه لن نقصر ان شاء الله

[يوسف السيد]

بارك الله لك وبارك فيك