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

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

جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جرب هذا Sub Macro1() Dim wo1 As Workbook, wo2 As Workbook Dim sh As Worksheet Dim MyPath As String Dim R As Integer, RR As Integer Dim Last As Long '''''''''''''''''''' On Error GoTo 1 Application.ScreenUpdating = False '''''''''''''''''''' Set wo1 = ThisWorkbook MyPath = wo1.Path & Application.PathSeparator & "Book2.xlsm" Set wo2 = Workbooks.Open(MyPath) Set sh = wo2.Worksheets("Book2") '''''''''''''''''''' wo1.Activate With sh For R = 1 To 35 If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(Last, "A").Value = Range("D5").Value2 .Cells(Last, "A").NumberFormat = "13-00000" .Cells(Last, "B").Value = Date .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value RR = RR + 1 End If Next End With ''''''''''''''''''''' If RR Then Range("D5").Value2 = Val(Range("D5")) + 1 Range("B8:G42").ClearContents End If '''''''''''''''''''' 1: wo2.Close True Application.ScreenUpdating = True If Err Then MsgBox Err.Number Set wo1 = Nothing Set wo2 = Nothing Set sh = Nothing End Sub تحياتي

السلام غليكم فكر راقي حفظكم الله وجزاكم خيرا وبارك فيكم تقبلوا تحياتي وشكري

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

السلام عليكم جرب هذا Sub Macro1() Dim wo As Workbook Dim sh As Worksheet Dim R As Integer, RR As Integer Dim Last As Long '''''''''''''''''''' On Error GoTo 1 Set wo = Workbooks("Book2") Set sh = wo.Worksheets("Book2") '''''''''''''''''''' With sh For R = 1 To 35 If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(Last, "A").Value = Range("D5").Value2 .Cells(Last, "A").NumberFormat = "13-00000" .Cells(Last, "B").Value = Date .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value RR = RR + 1 End If Next End With ''''''''''''''''''''' If RR Then Range("D5").Value2 = Val(Range("D5")) + 1 Range("B8:G42").ClearContents End If '''''''''''''''''''' 1: If Err Then MsgBox Err.Number Set wo = Nothing Set sh = Nothing End Sub تحياتي

السلام عليكم جرب هذا: Sub kh_Add_Row() Dim R As Integer For R = 100 To 1 Step -1 Cells(R, 1).EntireRow.Insert Next End Sub

السلام عليكم جرب هذ Sub Macro1() Dim wo1 As Workbook Dim sh1 As Worksheet Dim R As Integer Dim Last As Long '''''''''''''''''''' Set wo = Workbooks("Book2") Set sh = wo.Worksheets("Book2") '''''''''''''''''''' With sh For R = 1 To 35 If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(Last, "A").Value = Range("D5").Value .Cells(Last, "B").Value = Date .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value End If Next End With '''''''''''''''''''' Set wo = Nothing Set sh = Nothing End Sub المرفق 2010 Bjn3000.rar تحياتي

السلام عليكم جزاك الله خيرا اخي الحبيب بن علية ....في ميزان حسناتك ان شاء الله تقبلوا تحياتي وشكري

السلام عليكم حاولت عمل الاحتياطي بوضع حرف ح لكن ما زبط الكود هذا آخر ما توصلت له المرفق 2003 الملاحظة.rar

السلام عليكم اخي الحبيب / احمد فضيلة....حفطكم ربي اسعدني مروركم الطيب جزاكم الله خيرا وبارك فيكم تقبلوا تحياتي وشكري

السلام عليكم جرب هذا Sub KH_START() Dim Last1 As Long, Last2 As Long With ورقة2 Last1 = .Range("A" & .Rows.Count).End(xlUp).Row For R = 11 To Last1 If Val(.Cells(R, "C")) + Val(.Cells(R, "D")) Then Last2 = ورقة1.Range("A" & .Rows.Count).End(xlUp).Row + 1 ورقة1.Cells(Last2, "A").Value = .Cells(R, "B").Value ورقة1.Cells(Last2, "B").Value = .Cells(R, "A").Value End If Next End With End Sub او هذا Sub KH_START() Dim Last1 As Long, Last2 As Long With ورقة2 Last1 = .Range("A" & .Rows.Count).End(xlUp).Row For R = 11 To Last1 If Val(.Cells(R, "C")) + Val(.Cells(R, "D")) Then Last2 = ورقة1.Range("A" & .Rows.Count).End(xlUp).Row + 1 ورقة1.Cells(Last2, "A").Value = .Cells(R, "B").Value ورقة1.Cells(Last2, "B").Value = .Cells(R, "A").Value ورقة1.Cells(Last2, "C").Resize(1, 2).Value = .Cells(R, "C").Resize(1, 2).Value ورقة1.Cells(Last2, "E").Value = Val(.Cells(R, "C")) - Val(.Cells(R, "D")) End If Next End With End Sub تحياتي

السلام عليكم جرب الكود التالي: Sub kh_Start() Dim c%, r%, x%, y%, yy%, i% Dim FT%, LG%, AllCont%, iCont% LG = [N2] FT = [N3] AllCont = [H2] iCont = Abs(Int(AllCont / LG * -1)) '''''''''''''''' [D8:AH208 ].ClearContents For c = 1 To FT For r = 1 To AllCont i = 0 Randomize 1 x = Int(LG * Rnd + 1) i = i + 1 With Range("D8") .Cells(r, c) = x y = WorksheetFunction.CountIf(Range(.Cells(1, c), .Cells(AllCont, c)), .Cells(r, c)) yy = WorksheetFunction.CountIf(Range(.Cells(r, 1), .Cells(r, FT)), .Cells(r, c)) If i < 100 And (y > iCont Or yy > 1) Then GoTo 1 End With Next Next End Sub تحياتي

السلام عليكم اكرمك الله اخي الحبيب حمادة تقبلوا تحياتي وشكري

السلام عليكم حمد لله على السلامة نورت المنتدى تقبلوا تحياتي

السلام عليكم غير العدد والتوقيت بداية الكود ' عدد الحكم Private Const iCont As Integer = 57 ' التوقيت بالثانية Private Const MyTime As Double = 30 المرفق 2010 Hikam.rar

السلام عليكم جرب هذ الكود Option Explicit ' ' Sub kh_Start_MyPath() Dim MyDialg As FileDialog, spath As String On Error GoTo Err_Test_MyPath '========================================== Set MyDialg = Application.FileDialog(msoFileDialogFolderPicker) '========================================== 1: With MyDialg .Title = "اختيار مسار المجلد الذي تريد حفظ الملف فيه" .InitialFileName = ActiveWorkbook.Path & "\" .Show End With '========================================== If MyDialg.SelectedItems.Count Then spath = MyDialg.SelectedItems(1) If Dir(spath, vbDirectory) = vbNullString Then MsgBox " : لا يمكن الحفظ في المسار التالي" & vbCr & vbCr & spath _ & vbCr & vbCr & "يجب اختيار مسار صحيح لحفظ الملف فيه ", 524288, "مسار خاطىء" GoTo 1 Else Set MyDialg = Nothing ' اذا كان المسار صحيح يتم وضع الاوامر ادناه MsgBox spath End If End If '========================================== Err_Test_MyPath: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number Set MyDialg = Nothing End Sub في امان الله

السلام عليكم اخي حمادة.......جزاك ربي خيرا اخي مجدي يونس.......جزاك ربي خيرا تقبلوا تحياتي وشكري

السلام عليكم اخي مجدي يونس.......جزاك ربي خيرا تقبلوا تحياتي وشكري

السلام عليكم افكارك رائعة اخي الخالدي ...حفظكم ربي والشكر واصل للنشيط اخي الحبيب حمادة تقبلوا تحياتي وشكري

لا يمكن ذلك لان البيانات تلصق من اللست بوكس الى الشيت دفعة واحدة

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

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

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

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