الصق الكود التالي في مودويل
في ملف تحليل البيانات
على ان يكونو الملفين في فولدر واحد
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