استيراد بيانات من ملف آخر ( خبور خير )

[أيسم إبراهيم]

السلام عليكم

الأستا الفاضل

جزاك الله كل الخير على ما تقدم للجميع و جعله في ميزان حسناتك.

بعد الاطلاع عى إبداعك في ملف "" استيراد بيانات من ملف آخر "" هذا الكود سيحل لى مشاكل كثيرة في العمل

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

أتمنى من الله أن يكون هذا بالإمكان

مرفق ملف به الكود الذي أبدعته

جعلك الله دوما في قضاء حوائج الناس

_______.rar

[سامح حجاب]

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

كيف حالك أخي في الله أيسم

آسف لتطفلي على هذا الموضوع ولكن لحاجتي الماسة لكود أو معادلة تعينني على استيراد بيانات من مجموعة كبيرة من الملفات

وسأحاول الشرح بطريقة مبسطة ما أريده

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

ولدي كمية كبيرة من ملفات الاكسيل حيث كل ملف يحوي حاوية

ولكن من المفترض أن أكون شيت يومي بالبضاعة التي تخرج من المستودع يوميا وبالتالي أضطر إلى كتابتها يدوي ثم تسجيلها يدوي على الكمبيوتر

هل هناك طريقة أو كود يقوم بهذه المهمة بطريقة آلية على كل الملفات بحيث يستورد البيانات من كل الملفات عن طريق التاريخ

مع العلم أن كل بضاعة تخرج أفتح الملف الخاص بها وأسجل أمامها التاريخ التي خرجت به

وأكون شاكر لردك

وآسف أخي أيسم لتطفلي على موضوعك ولكن لترابط العلاقة بين سؤالي وموضوعك تدخلت

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

[عبدالله باقشير]

السلام عليكم

الاخ الفاضل / عصام ---------------حفظه الله

تفضل المرفق

وفيه شرح مبسط في الكود :

Option Explicit
Dim Mybook As Workbook
Dim path As String
Dim MyRange As Range
Dim MyCell As Range
Dim Last_Count As Integer
Dim LastRow As Integer
Private Sub CommandButton2_Click()
Mybook.Activate
Unload Me
End Sub
Private Sub KHOpenFilename_Click()
On Error GoTo 1
path = Application.GetOpenFilename(Title:="Select database location")
KH_TEXT.Text = path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Workbooks.Open path
    RefEdit1.SetFocus
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
On Error GoTo 0
1 End Sub
Private Sub KHCOPYMYRANGE_Click()
  On Error Resume Next
  Dim MySheet As Workbook
  Dim M As Integer, N As Integer, NN As Integer, C As Integer
  Dim lRows As Integer
  If RefEdit1.Text = "" Then GoTo 1
  On Error GoTo 1
  kh_focopy.Hide
  Application.ScreenUpdating = False
    With Range([RefEdit1])
        M = .Rows.Count
        For lRows = 1 To M
            If .Cells(lRows, 1) <> "" Then
                '=======================================================
                ' كل صفين يتم اضافة البيانات
                N = N + 2
                '=======================================================
                ' تسلسل  البيانات المرحلة
                NN = N / 2
                MyCell.Cells(N, 1) = NN + Last_Count
                '=======================================================
                ' سلسلة اعمدة البيانات تمتد من 1 الى 92  بداية من عمود الاسماء
                For C = 1 To 92
                        '  ترحيل البيانات
                    MyCell.Cells(N, C + 1) = .Cells(lRows, C)
                Next C
               '=======================================================
            End If
        Next lRows
    End With
    '=======================================================
    MsgBox "تم استيراد عدد " & Chr(32) & NN & Chr(32) & " من السجلات بنجاح", 524288 + vbMsgBoxRtlReading, "الحمدلله"
    '=======================================================
    Application.ScreenUpdating = True
    Mybook.Activate
    End
    GoTo 2
1:
    MsgBox "استخدام خاطىء", 524288, "تنبيه"
    On Error GoTo 0
2 End Sub
Private Sub UserForm_Initialize()
Dim X As Integer
Set Mybook = ActiveWorkbook
With ActiveSheet
    '==============================
    '  اول صف في البيانات الاساسية هو 14
    X = 14
    '  آخر صف في البيانات الاساسية زايدا 1
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   '==============================
    If LastRow < X Then LastRow = X
    Set MyCell = .Range("A" & LastRow)
    '==============================
    '   عدد البيانات لاحتساب الرقم التسلسلي Last_Count
    Last_Count = Application.WorksheetFunction.CountA(.Range("A" & X & ":A" & LastRow))
End With
End Sub

===========================================================

الاخ الفاضل / IMAG---------------حفظه الله

اجعل الطلب في موضوع آخر مع ارسال مرفقات كامثلة

ودمتم في حفظ الله

________.rar

[خالد القدس]

أستاذنا الفاضل خبور خير

بارك الله فيك وجزاك خيرا على هذه الابداعات

وجعلها الله في ميزان حسناتك

[أيسم إبراهيم]

السلام عليكم

العلامة خبور الخير

بسم الله ما شاء الله عليك.

الغول الأخطبوط المسمى لدينا بالـ VBA في يدك طيع هين لين .يلبي أي طلب تشير له به

جزاك الله كل الخير و جعله في ميزان حسناتك