التعديل على هذا الكود

[ياسر أحمد الشيخ]

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

هذا كود يقوم بتجميع بيانات من فولدر ووضعه فى ملف جديد بالشكل التالى:

اسماء الملفات فى العمودA ، والبيانات فى العمودB

فتكون البيانات كلها فى عمود واحد

Sub MergeAllWorkbooks()

    Dim MyPath As String, FilesInPath As String

    Dim MyFiles() As String

    Dim SourceRcount As Long, FNum As Long

    Dim mybook As Workbook, BaseWks As Worksheet

    Dim sourceRange As Range, destrange As Range

    Dim rnum As Long, CalcMode As Long

    ' Change this to the path\folder location of your files.

    MyPath = "E:\Excel work\Daily plant report\dog"

    ' Add a slash at the end of the path if needed.

    If Right(MyPath, 1) <> "\" Then

	    MyPath = MyPath & "\"

    End If

    ' If there are no Excel files in the folder, exit.

    FilesInPath = Dir(MyPath & "*.xl*")

    If FilesInPath = "" Then

	    MsgBox "No files found"

	    Exit Sub

    End If

    ' Fill the myFiles array with the list of Excel files

    ' in the search folder.

    FNum = 0

    Do While FilesInPath <> ""

	    FNum = FNum + 1

	    ReDim Preserve MyFiles(1 To FNum)

	    MyFiles(FNum) = FilesInPath

	    FilesInPath = Dir()

    Loop

    ' Set various application properties.

    With Application

	    CalcMode = .Calculation

	    .Calculation = xlCalculationManual

	    .ScreenUpdating = False

	    .EnableEvents = False

    End With

    ' Add a new workbook with one sheet.

    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    rnum = 1

    ' Loop through all files in the myFiles array.

    If FNum > 0 Then

	    For FNum = LBound(MyFiles) To UBound(MyFiles)

		    Set mybook = Nothing

		    On Error Resume Next

		    Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))

		    On Error GoTo 0

		    If Not mybook Is Nothing Then

			    On Error Resume Next

			    ' Change this range to fit your own needs.

				    With mybook.Worksheets("production")

				    Set sourceRange = .Range("b2:b8")

			    End With

			    If Err.Number > 0 Then

				    Err.Clear

				    Set sourceRange = Nothing

			    Else

				    ' If source range uses all columns then

				    ' skip this file.

				    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then

					    Set sourceRange = Nothing

				    End If

			    End If

			    On Error GoTo 0

			    If Not sourceRange Is Nothing Then

				    SourceRcount = sourceRange.Rows.Count

				    If rnum + SourceRcount >= BaseWks.Rows.Count Then

					    MsgBox "There are not enough rows in the target worksheet."

					    BaseWks.Columns.AutoFit

					    mybook.Close savechanges:=False

					    GoTo ExitTheSub

				    Else

					    ' Copy the file name in column A.

					    With sourceRange

						    BaseWks.Cells(rnum, "A"). _

								    Resize(.Rows.Count).Value = MyFiles(FNum)

					    End With

					    ' Set the destination range.

					    Set destrange = BaseWks.Range("B" & rnum)

					    ' Copy the values from the source range

					    ' to the destination range.

					    With sourceRange

						    Set destrange = destrange. _

										    Resize(.Rows.Count, .Columns.Count)

					    End With

					    destrange.Value = sourceRange.Value

					    rnum = rnum + SourceRcount

				    End If

			    End If

			    mybook.Close savechanges:=False

		    End If

	    Next FNum

	    BaseWks.Columns.AutoFit

    End If

ExitTheSub:

    ' Restore the application properties.

    With Application

	    .ScreenUpdating = True

	    .EnableEvents = True

	    .Calculation = CalcMode

    End With

End Sub

لى طلبين :

1- اريد أن يقوم الكود بتجاهل أى أخطاء فى اللينكات الموجودة فى الملفات حيث تظهر الرسالة التالي:ه This workbook contains one or more links that cannot be updated

أو أى أخطاء أخرى أريده أن يتجاهلها

2- أريد أن يقوم الكود (فى الملف الجديد الذي يقوم بنجميع البيانات به )بأن يضع اسماء الملفات فى الصف رقم 1 ، والبيانات فى الصفوف التالي

أى كل ملف له عمود

وشكرا

[ياسر أحمد الشيخ]

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

يا جماعة ارجو الرد على طلبى

لقد وضعت الجزء الخاص بطلبي من الكود الكبير الذي بالاعلى لتحديد مكان التغيير

هذا الجزء يختص بوضع البيانات بهذا الشكل:

اسماء الملفات فى العمودA ، والبيانات فى العمودB

فتكون البيانات كلها فى عمود واحد

' Copy the file name in column A.

										    With sourceRange

												    BaseWks.Cells(rnum, "A"). _

																    Resize(.Rows.Count).Value = MyFiles(FNum)

										    End With

										    ' Set the destination range.

										    Set destrange = BaseWks.Range("B" & rnum)

										    ' Copy the values from the source range

										    ' to the destination range.

										    With sourceRange

												    Set destrange = destrange. _

																				    Resize(.Rows.Count, .Columns.Count)

										    End With

										    destrange.Value = sourceRange.Value

										    rnum = rnum + SourceRcount

								    End If

اريد أن يكون التغيير كالتالى:

( يضع اسماء الملفات فى الصف رقم 1 ، والبيانات فى الصفوف التالية )

------>> أى كل ملف له عمود (اسم الملف فى أول خانه ، والبيانات أسفله فى نفس العمود )

حيث لو عندنا 30 ملف ، يقوم الكود بوضع البيانات فى 30 عمود

وشكرا

[الحسامي]

السلام عليكم

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

وساحاول على قدر استطاعتي في التعديل

[ياسر أحمد الشيخ]

يا استاذ الحسامى أرجو منك الرد على الموضوع

1- لقد وضعت الجزء الخاص بالتعديل وهو فى المشاركة الثانية حتى لا تتعب نفسك فى البحث

2- وأرجو اضافة كود لتجاهل الاخطاء فى الملفات المصدر حيث يظهر الخطأ التالى:

This workbook contains one or more links that cannot be updated

سارفق الكود مرة أخرى

' Copy the file name in column A.

										    With sourceRange

												    BaseWks.Cells(rnum, "A"). _

																    Resize(.Rows.Count).Value = MyFiles(FNum)

										    End With

										    ' Set the destination range.

										    Set destrange = BaseWks.Range("B" & rnum)

										    ' Copy the values from the source range

										    ' to the destination range.

										    With sourceRange

												    Set destrange = destrange. _

																				    Resize(.Rows.Count, .Columns.Count)

										    End With

										    destrange.Value = sourceRange.Value

										    rnum = rnum + SourceRcount

								    End If

أرجو الرد والاهتمام يا جماعة لأنى اديلى شهر كامل عايز احل الموضوع ده

وما فيش حد راضي يرد عليا ولا يبل ريقى بأى رد

شكرا جزيلا

[ياسر أحمد الشيخ]

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

كل سنه وانتم طيبين يا جماعة

ارجو الرد يا جماعة

لأن الموضوع هام جدا وخطير