بحث مخصص من جوجل فى أوفيسنا
![]()
Custom Search
|
![](https://www.officena.net/ib/uploads/set_resources_32/84c1e40ea0e759e3f1505eb1788ddf3c_pattern.png)
lionheart
الخبراء-
Posts
658 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
27
lionheart last won the day on يونيو 24 2023
lionheart had the most liked content!
السمعه بالموقع
941 Excellentعن العضو lionheart
![](https://www.officena.net/ib/uploads/monthly_2020_06/Expert.png.f1698934bdf1ae38ebc9b5dbeba06a68.png)
البيانات الشخصية
-
Gender (Ar)
ذكر
-
Job Title
Programmer
-
البلد
Egypt
-
الإهتمامات
Programming
اخر الزوار
بلوك اخر الزوار معطل ولن يظهر للاعضاء
-
احتاج دالة نقل بيانات من جدول بطريقة عمودية
lionheart replied to الشافعي's topic in منتدى الاكسيل Excel
Try this code Sub Test() Const SROW As Long = 6 Dim w, m As Long, r As Long, n As Long Application.ScreenUpdating = False With ActiveSheet .Columns("L:M").ClearContents m = SROW For r = SROW To .Cells(Rows.Count, "J").End(xlUp).Row n = .Cells(r, "I").Value If n > 0 Then .Cells(m, "L").Resize(n).Value = .Cells(r, "J").Value m = m + n End If Next r m = m - SROW w = Evaluate("ROW(1:" & m & ")") .Range("M" & SROW).Resize(UBound(w, 1)).Value = w End With Application.ScreenUpdating = True End Sub -
مساعدة فى تصدير بيانات من الليست بوكس الى ورقة العمل
lionheart replied to mody200's topic in منتدى الاكسيل Excel
The code is already OK as it exports data from the listbox to the worksheet Just comment out those two lines For X = 0 To ListBox1.ListCount - 1 Next X as I don't see any need to loop through the items of the listbox -
لدي ملف اكسيل و اريد نقل بيانات من شيت الي شيت اخر
lionheart replied to ahmedhassan1948's topic in منتدى الاكسيل Excel
In sheet [Template] put the formula in cell C3 =INDEX(Support!A:A,MATCH(Criteria,Support!B:B,0)) -
Try this formula =MID(LEFT(A1,LEN(A1)-6),5,LEN(LEFT(A1,LEN(A1)-6)))
-
Not so clear but try this code Sub Test() Dim a, letters, i As Long, ii As Long, k As Long a = Sheet1.Range("C1").CurrentRegion.Value Rem letters = Split("ا,أ,إ,آ", ",") letters = Split("ب", ",") ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 2 To UBound(a, 1) If IsNumeric(Application.Match(Left(a(i, 2), 1), letters, 0)) Then k = k + 1 For ii = LBound(a, 2) To UBound(a, 2) b(k, ii) = a(i, ii) Next ii End If Next i If k > 0 Then With Sheet2 .Columns("C:E").ClearContents .Range("C1").Resize(, 3).Value = Sheet1.Range("C1").Resize(, 3).Value .Range("C2").Resize(k, UBound(b, 2)).Value = b End With End If End Sub
-
تحويل الاعداد من الحالة الافقية الى تسلسل راسي
lionheart replied to خير الايمان's topic in منتدى الاكسيل Excel
Try to read the code to add a fourth column in the output. The code is so simple to read -
تحويل الاعداد من الحالة الافقية الى تسلسل راسي
lionheart replied to خير الايمان's topic in منتدى الاكسيل Excel
Try Sub Test() Dim ws As Worksheet, m As Long, i As Long, ii As Long Application.ScreenUpdating = False Set ws = ActiveSheet: m = 2 With ws .Columns("K:M").Clear .Columns("M").ColumnWidth = 11 With .Range("K1").Resize(, 3) .Value = Array("Group", "Number", "Work Date") .Interior.Color = RGB(146, 205, 220) .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With For i = 2 To 6 If .Cells(i, 2).Value < .Cells(i, 3).Value And IsNumeric(.Cells(i, 2).Value) And IsNumeric(.Cells(i, 2).Value) Then For ii = .Cells(i, 2).Value To .Cells(i, 3).Value .Cells(m, "K").Resize(, 3).Value = Array(.Cells(i, 1).Value, ii, .Cells(i, 4).Value) m = m + 1 Next ii End If Next i End With Application.ScreenUpdating = True End Sub -
تلوين خليه لو وجد مجلد اسمه بنفس قيمه الخليه
lionheart replied to تامر خليفه's topic in منتدى الاكسيل Excel
Do it yourself Press Alt + F11 >> Insert Module >> Paste the code -
تلوين خليه لو وجد مجلد اسمه بنفس قيمه الخليه
lionheart replied to تامر خليفه's topic in منتدى الاكسيل Excel
Try this code Sub Test() Dim ws As Worksheet, fso As Object, sPath As String, lr As Long, iRow As Long Set ws = ActiveSheet Set fso = CreateObject("Scripting.FileSystemObject") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ws.Columns(1).Interior.Color = xlNone For iRow = 2 To lr sPath = ThisWorkbook.Path & "\" & ws.Cells(iRow, 1).Value If fso.FolderExists(sPath) Then ws.Cells(iRow, 1).Interior.Color = vbGreen End If Next iRow End Sub -
Here's a version that merges cells although I see not practical and not useful later Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, n As Long, i As Long, c As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5: n = m Application.ScreenUpdating = False Application.DisplayAlerts = False With sh.Rows("5:" & Rows.Count) .ClearContents: .Borders.Value = 0: .UnMerge: .RowHeight = 20.25 End With For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i For c = 1 To 3 With sh.Range(sh.Cells(n, c), sh.Cells(m - 1, c)) .Merge: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Next c If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 n = m End If Next r sh.Range("A5:F" & m - 1).Borders.Value = 1 Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
-
Here's a modification to let empty row between results but I won't merge cells Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5 Application.ScreenUpdating = False For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i If lr = r Then Exit For sh.Cells(m, 1).Resize(, 4).Interior.Color = vbMagenta m = m + 1 End If Next r Application.ScreenUpdating = True End Sub
-
Delete the rows in sheet2 from row 5 to row 25 then try this code Sub Test() Dim ws As Worksheet, sh As Worksheet, lr As Long, r As Long, m As Long, i As Long Set ws = ThisWorkbook.Worksheets("1") Set sh = ThisWorkbook.Worksheets("2") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then Exit Sub m = 5 Application.ScreenUpdating = False For r = 6 To lr If ws.Cells(r, 4).Value > 0 Then For i = 1 To ws.Cells(r, 4).Value sh.Cells(m, 1).Value = ws.Cells(r, 2).Value sh.Cells(m, 2).Value = ws.Cells(r, 3).Value sh.Cells(m, 3).Value = ws.Cells(r, 4).Value sh.Cells(m, 4).Value = ws.Range("D3").Value & ws.Cells(r, 1).Value & ws.Cells(r, 2).Value & i m = m + 1 Next i End If Next r Application.ScreenUpdating = True End Sub I didn't merge the cells as it is not practical
-
Whar are the expected correct results exactly I have tried UDF on my side and these are the results 04-11-04 04-11-00 04-10-30 04-10-29 04-10-28 04-10-27 04-10-26