اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

lionheart

الخبراء
  • Posts

    141
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    2

lionheart last won the day on سبتمبر 26

lionheart had the most liked content!

السمعه بالموقع

179 Excellent

7 متابعين

عن العضو lionheart

البيانات الشخصية

  • Gender (Ar)
    ذكر
  • Job Title
    Programmer
  • البلد
    Egypt
  • الإهتمامات
    Programming

اخر الزوار

بلوك اخر الزوار معطل ولن يظهر للاعضاء

  1. Option Explicit Private Sub CommandButton1_Click() UpdateListBox "WEEK 1" End Sub Private Sub CommandButton2_Click() UpdateListBox "WEEK 2" End Sub Private Sub CommandButton3_Click() UpdateListBox "WEEK 3" End Sub Private Sub CommandButton4_Click() UpdateListBox "WEEK 4" End Sub Sub UpdateListBox(ByVal sWeek As String) Dim ws As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets(1) For i = 0 To UserForm1.ListBox1.ListCount - 1 If UserForm1.ListBox1.Selected(i) Then ListBox1.List(i, 4) = sWeek ws.Cells(i + 3, 11) = sWeek End If Next i Call CommandButton5_Click End Sub Private Sub CommandButton5_Click() Dim deg1, deg4, deg6, deg8, deg2 As String, deg3 As String, deg5 As String, deg7 As String, sat As Long, s As Long With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With With ListBox1 .Clear .ColumnCount = 8 .ColumnWidths = "80;190;100;80;0;110,100" End With deg2 = "AUGUST" deg3 = "AUGUST" deg5 = "AUGUST" deg7 = "AUGUST" For sat = 3 To Sheet1.Cells(65536, "F").End(xlUp).Row Set deg1 = Sheet1.Cells(sat, "F") Set deg4 = Sheet1.Cells(sat, "G") Set deg6 = Sheet1.Cells(sat, "H") Set deg8 = Sheet1.Cells(sat, "I") If UCase(deg1) Like UCase(deg2) Or UCase(deg3) Like UCase(deg4) Or UCase(deg5) Like UCase(deg6) Or UCase(deg7) Like UCase(deg8) Then ListBox1.AddItem ListBox1.List(s, 0) = Sheet1.Cells(sat, "A").Value ListBox1.List(s, 1) = Sheet1.Cells(sat, "C").Value ListBox1.List(s, 2) = Sheet1.Cells(sat, "B").Value ListBox1.List(s, 3) = Sheet1.Cells(sat, "D").Value ListBox1.List(s, 5) = Sheet1.Cells(sat, "N").Value ListBox1.List(s, 6) = Sheet1.Cells(sat, "J").Value ListBox1.List(s, 7) = Sheet1.Cells(sat, "K").Value s = s + 1 End If Next sat With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub
  2. Private Sub UserForm_Initialize() Rem 1 = Second Column In ListBox Const cToSum As Integer = 1 Dim arr(1 To 6, 1 To 3) As String, i As Long, j As Long, t As Long, d As Double For i = 1 To 6 For j = 1 To 3 t = Application.WorksheetFunction.RandBetween(-1, 1) If t = 0 Then t = 1 arr(i, j) = i * j * t Next j Next i With ListBox1 .Clear .ColumnCount = UBound(arr, 2) .List = arr() End With With ListBox1 For i = 0 To .ListCount - 1 If .List(i, cToSum) > 0 Then d = d + .List(i, cToSum) Next i TextBox1.Value = d End With End Sub
  3. Sub Test() Dim r As Range, c As Long Application.ScreenUpdating = False With ActiveSheet Set r = .Range("L4:L" & .Cells(Rows.Count, "L").End(xlUp).Row) c = .Cells(4, Columns.Count).End(xlToLeft).Column + 1 .Cells(4, c).Resize(r.Rows.Count).Value = r.Value End With Application.ScreenUpdating = True End Sub
  4. Sub Test() Dim s$ s = "D:\Programation\VISUAL STUDIO\Projectes\DATA.xls" MsgBox Split(s, "\")(UBound(Split(s, "\"))) End Sub
  5. Private Sub TextBox1_Change() Dim dFrom As Date, dTo As Date, lr As Long With ActiveSheet lr = .Range("B" & Rows.Count).End(xlUp).Row If TextBox1.Text <> "" Then .AutoFilterMode = False dFrom = .Range("F1").Value2 dTo = .Range("G1").Value2 With .Range("B2:Q" & lr) .AutoFilter Field:=1, Criteria1:="=" & TextBox1.Text & "*", Operator:=xlOr .AutoFilter 8, ">=" & CLng(dFrom), xlAnd, "<=" & CLng(dTo) End With Else .AutoFilterMode = False End If End With End Sub
  6. Sub Test() Dim a, v, w1 As Worksheet, w2 As Worksheet, dic As Object, s As String, i As Long, m As Long, cnt As Long Set w1 = Sheet1: Set w2 = Sheet2 Set dic = CreateObject("Scripting.Dictionary") a = w1.Range("A4").CurrentRegion.Value For i = 2 To UBound(a) s = a(i, 1) & Chr(2) & a(i, 2) & Chr(2) & a(i, 3) dic(s) = Empty Next i With w2 For i = 5 To .Cells(Rows.Count, 1).End(xlUp).Row s = Empty s = .Cells(i, 1) & Chr(2) & .Cells(i, 2) & Chr(2) & .Cells(i, 3) If Not dic.Exists(s) Then m = w1.Cells(Rows.Count, 1).End(xlUp).Row + 1 v = Split(s, Chr(2)) w1.Range("A" & m).Resize(1, 3).Value = v cnt = cnt + 1 End If Next i End With If cnt > 0 Then MsgBox "New Items Added = " & cnt, 64 Else MsgBox "No New Items", vbExclamation End Sub
  7. Sub Test() Dim a a = GetDates(Range("D1").Value2, Range("F1").Value2) Range("D3").Resize(UBound(a)).Value = Application.Transpose(a) End Sub Function GetDates(ByVal startDate As Date, ByVal endDate As Date) Dim v() As Date, cnt As Long ReDim v(1 To CLng(endDate) - CLng(startDate) + 1) For cnt = LBound(v) To UBound(v) v(cnt) = CDate(startDate) startDate = CDate(CDbl(startDate) + 1) Next cnt GetDates = v If IsArray(v) Then Erase v cnt = Empty End Function
  8. Target(2, 1).Resize(1, 8).Interior.Color = &HFF00& Target(2, 1).Offset(, 1).Resize(1, 4).Merge
  9. Sub Test() Dim w1 As Worksheet, w2 As Worksheet, c As Range, n As Long Set w1 = Sheets("2020"): Set w2 = Sheets("2021") n = w2.Cells(Rows.Count, 1).End(xlUp).Row + 1 For Each c In w1.Range("A5").CurrentRegion.Columns(5).Cells If c.Value = "Active" Then w2.Range("A" & n).Resize(1, 5).Value = c.Offset(, -4).Resize(1, 5).Value n = n + 1 End If Next c End Sub
  10. Sub pastespc() Dim t As Long, r As Long, m As Long lr = Range("d" & Rows.Count).End(3).Row + 5 t = lr Range("a1:e34").Copy Range("a" & lr) m = Range("d" & Rows.Count).End(3).Row For r = m To t + 5 Step -1 If Application.CountA(Range("A" & r).Resize(1, 4)) = 0 Then Range("A" & r).Resize(1, 5).Delete End If Next r If Cells(8, 2) <> "" Then lrr2 = Range("h" & Rows.Count).End(xlUp).Row + 1 Else lrr2 = Range("h" & Rows.Count).End(xlUp).Row + 1 ActiveSheet.Hyperlinks.Add anchor:=Cells(lrr2, 8), Address:="", SubAddress:="ÝÇÊæÑÉ!" & "e" & lr + 2 End If Cells(lrr2, 8) = [e3] Cells(lrr2, 9) = [c5] Cells(lrr2, 10) = [b7] Cells(lrr2, 11) = [e32] [e3] = [e3] + 1 End Sub
  11. Try by yourself first and then write your notes. I will not waste my time with unclear topics
×
×
  • اضف...

Important Information