كود ترحيب بيانات

[2saad]

إخواني اعضاء المنتدي الكرام بعد التحية والسلام

محتاج ارحل البيانات الموجودة في الملف ( محمد ) بالشيت الاول والبيانات الموجودة في ملف ( أحمد ) بالشيت الاول 

الي الشيت 9 ( ورقة عمل 9 ) بملف أحمد

ولكم جزيل الشكر

أحمد.xlsmمحمد.xlsm 

 

[محمد هشام.]

تفضل 

Sub Copy_My_Data()
Dim wsDest  As Worksheet
Dim LR      As Long, LR1 As Long
Dim msg     As VbMsgBoxResult
Dim Rng     As Range, wsCopy As Worksheet
 
 msg = MsgBox(" ترحيل البيانات الى مصنف أحمد  ؟", vbYesNo + vbQuestion + vbDefaultButton2, "تأكيد")
If msg = vbYes Then
Application.ScreenUpdating = False

Set wsCopy = Sheets("Sheet1")
    With wsCopy
LR = .Cells(Rows.Count, 3).End(xlUp).Row
    Set Rng = .Range(.Cells(10, "C"), .Cells(LR, "L"))
End With
Set wsDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet9")
   LR1 = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row + 1
If wsDest.Range("C10") = Empty Then
Rng.Copy
wsDest.Range("C10").PasteSpecial Paste:=xlPasteValues
    Else
Rng.Copy
wsDest.Range("C" & LR1).PasteSpecial Paste:=xlPasteValues
End If

Set WS = Workbooks("أحمد.xlsm").Sheets("Sheet1")
  WCopy = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row
    WDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row
WS.Range("C10:L" & WCopy).Copy
    wsDest.Range("C" & WDest).PasteSpecial Paste:=xlPasteValues
[C10].Select
Application.CutCopyMode = False
Workbooks("أحمد.xlsm").Close True
Application.ScreenUpdating = True

       End If

End Sub

 

 

Saad2.rar

[2saad]

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

ومعلش أنا بتعبك معاي أخوك لسه مبتدئ