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

سليم حاصبيا

أوفيسنا
  • Posts

    8,723
  • تاريخ الانضمام

  • Days Won

    262

Community Answers

  1. سليم حاصبيا's post in ترحيل بيانات من عدة صفحات الى صفحة واحدة was marked as the answer   
    تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ)
    Option Explicit Option Base 1 Sub Salim_Extract() Dim Src_Sh As Worksheet Dim Trg_Sh As Worksheet Dim xx, lr, m, My_Row As Integer Dim ArrJ(), ArrG() Dim t As Long Application.ScreenUpdating = False My_Row = 4 Set Trg_Sh = Sheets("الديون") Trg_Sh.Range("e4").Resize(10000, 3).Clear For m = 3 To Sheets.Count - 2 t = 1 Set Src_Sh = Sheets(m) With Src_Sh .Select On Error GoTo 1 On Error Resume Next lr = .Cells(Rows.Count, "j").End(3).Row For xx = 4 To lr If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then ReDim Preserve ArrJ(t) ReDim Preserve ArrG(t) ArrJ(t) = .Cells(xx, "j").Value ArrG(t) = .Cells(xx, "G").Value: t = t + 1 End If Next End With Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG) Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy" My_Row = My_Row + t Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6 1: Erase ArrJ: Erase ArrG Next Application.ScreenUpdating = True Trg_Sh.Activate: Range("e3").Select End Sub الملف المرفق 
    اصنافform salim 1.rar
  2. سليم حاصبيا's post in طلب ترحيل بشروط واضافه الى السابق ترحيله was marked as the answer   
    لتجاوز الاحطاء تم تعديل الكود
    Sub transfer_with_ٍSalim1() Dim Sht_Source, Sht_Target As Worksheet Dim lr1, lr2, My_Row, My_Column As Integer Dim My_Name As String, Oldsum Dim My_Error As Long Set Sht_Source = Sheets("المكافآة"): Set Sht_Target = Sheets("تجميع المكافآت على مدار العام") lr1 = Sht_Source.Cells(Rows.Count, 1).End(3).Row lr2 = Sht_Target.Cells(Rows.Count, 1).End(3).Row My_Column = Application.Match(Sht_Source.Range("d2"), Sht_Target.Range("c4:n4"), 0) + 2 For i = 5 To lr1 On Error Resume Next My_Name = Sht_Source.Range("b" & i).Value My_Row = Application.Match(My_Name, Sht_Target.Range("b5:b" & lr2), 0) + 4 '============================================== My_Error = Err.Number: If My_Error <> 0 Or My_Name = "" Then GoTo 1 Oldsum = Sht_Target.Cells(My_Row, My_Column) Sht_Target.Cells(My_Row, My_Column) = Oldsum + Sht_Source.Cells(i, 3) '============================================== 1: My_Error = 0 Next End Sub  
  3. سليم حاصبيا's post in فصل الارقام عن النص was marked as the answer   
    ربما كان المطلوب
     
    Extract_num_Or_letters.rar
  4. سليم حاصبيا's post in معرفة الاسماء المتكررة بين ورقتين في ملف واحد was marked as the answer   
    ربما يكون المطلوب
     
     
    مثال salim.zip
  5. سليم حاصبيا's post in اضافة معادلة sumif فى TextBox فى اليوزرفروم was marked as the answer   
    ربما كان المطلوب
    الاسماء تضاف تلقائيا الى الكومبو و ترتب ابجدياً بدون تكرار
     
    form1.rar
  6. سليم حاصبيا's post in بحث بالمعادلات was marked as the answer   
    تم التعديل غلى الملف ليظهر كل الاسماء حسب البحث دفعة وحدة
     
    تعديل احمد عبد الرحمن salim.rar
  7. سليم حاصبيا's post in بحث بالمعادلات was marked as the answer   
    الصفحة "Salim" من هذا الملف
    Marwa.xlsm
  8. سليم حاصبيا's post in استدعاء البيانات بالمعادلات was marked as the answer   
    جرب هذا لملف
     
    Chidren.zip
  9. سليم حاصبيا's post in وضع 1 امام عامود القيمه 5 وعمل ترقيم بمجرد كتابه قيمه was marked as the answer   
    جرب هذا الملف
    الماكرو في الصفحة الاولى (حينما تغير اي شيء في العامود الاول يغمل الماكرو تلقائياً بشرط ان يكون التغيير في خلية واحدة)
    بالنسبة للسؤال الثاني انظر الى الصفحة 2
    work_with_5.rar
  10. سليم حاصبيا's post in معادلة جمع قيمة شهر وقيمة سنة was marked as the answer   
    هذه المعادلة
    =IF(OR(C3<1,C3>12,ISTEXT(C3)),"",13-C3)  
  11. سليم حاصبيا's post in دالة if مع دالة round was marked as the answer   
    اليك الحل على طريقتين
    m_79.rar
  12. سليم حاصبيا's post in مطابقة ارقام مع اكسل وفي حال ايجادها يتم كتابة ملاحظة دايركت was marked as the answer   
    ربما كان المطلوب
    Faris.xlsx
  13. سليم حاصبيا's post in ربط الخلية بما قبلها was marked as the answer   
    جرب هذه الملف في النطاق A2:k11 (يمكن تعديل هذا النطاق من داخل الكود)
    الكود مرفق
    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim col%, r%, x%, t% Application.EnableEvents = False Set my_rg = Range("a2:k11") If Intersect(Target, my_rg) Is Nothing Then GoTo 1 If Target.Rows.Count <> 1 Then GoTo 1 r = Target.Row: col = Target.Column t = Cells(r, 1).End(xlToRight).Column: If t > 11 Then t = 1 x = Application.CountA(Range(Cells(r, 1), Cells(r, col))) If x <> col Then MsgBox ("Out Of range") Target.Value = vbNullString If t = 1 Then Cells(r, 1).Select Else Cells(r, t + 1).Select End If End If 1: Application.EnableEvents = True End Sub الملف 
    No_cells_to_skeep.rar
  14. سليم حاصبيا's post in عد عدد الكلمات أو الفراغات في خلية was marked as the answer   
    =LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A1)," ",""))+1 لمعرفة عدد الكلمات هذه المعادلة
    لمعرفة عدد الفراغات  هذه الثانية
    =LEN(TRIM(A1))-LEN(SUBSTITUTE(TRIM(A1)," ",""))  
     
     
  15. سليم حاصبيا's post in كشف حساب (الدائن - المدين) لكل عميل was marked as the answer   
    حرب هذا الملف
    لا ضرورة لادراج اكثر من 700 صف
    لان المكرو الذي يعمل على صف واجد يستطيع العمل على الألوف منها
    يكفي ادراج نموذح بسيط لما تريد (50 صف كحد أقصى)
    كما اني لم أفهم ما هي  الحاجة الى اليوزر فورم؟؟؟
    Option Explicit Sub Get_data() Dim H As Worksheet Dim T As Worksheet Dim LrH%, LrT%, i%, Sd#, _ k%, Se#, My_val#, n% Dim Date1 As Date, Date2 As Date Dim M_date As Date, X_date As Date Dim Fr As Range, Wat As Range, Ro1%, Ro2% Dim x As Boolean, y As Boolean Set H = Sheets("Haraka") Set T = Sheets("Takrir") LrH = H.Cells(Rows.Count, 1).End(3).Row LrT = 20 T.Range("D5").Resize(LrT, 3).ClearContents Date1 = Application.Min(H.Range("C4:C" & LrH)) Date2 = Application.Max(H.Range("C4:C" & LrH)) If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Please Type Dates in D2 and E2" Exit Sub End If M_date = T.Range("D2"): X_date = T.Range("E2") If Not IsDate(T.Range("D2")) Or Not IsDate(T.Range("E2")) Then MsgBox "Wrong Dates" Exit Sub End If T.Range("D2") = Application.Min(M_date, X_date) T.Range("E2") = Application.Max(M_date, X_date) M_date = T.Range("D2"): X_date = T.Range("E2") Set Wat = H.Range("A3:A" & LrH) For i = 5 To LrT Set Fr = Wat.Find(T.Range("B" & i), lookat:=1) If Fr Is Nothing Then GoTo Again Ro1 = Fr.Row: Ro2 = Ro1 Do x = H.Range("C" & Ro2) >= M_date y = H.Range("C" & Ro2) <= X_date If x And y Then Sd = Sd + Val(H.Range("D" & Ro2)) Se = Se + Val(H.Range("E" & Ro2)) n = n + 1 End If Set Fr = Wat.FindNext(Fr) Ro2 = Fr.Row If Ro2 = Ro1 Then Exit Do Loop T.Range("D" & i) = IIf(Sd = 0, "", Sd) T.Range("E" & i) = IIf(Se = 0, "", Se) My_val = Val(T.Range("C" & i)) + Val(T.Range("D" & i)) _ - Val(T.Range("E" & i)) T.Range("F" & i) = IIf(My_val = 0, "", My_val) T.Range("G" & i) = IIf(n = 0, "", n) Again: Sd = 0: Se = 0: n = 0 Next i End Sub T_Mansour.xlsm
  16. سليم حاصبيا's post in البحث في نطاق محدد was marked as the answer   
    Try This File
    Jalal.xlsx
  17. سليم حاصبيا's post in اريد عمل جدول عائلة الكلمات في اللغة الانجليزية was marked as the answer   
    اذا كان ما فهمته صحيحاً هذا الكود (فقط اضغط الزر Run)
    Option Explicit Sub Creezy_sort() Dim CoL As Object Dim Lr%, i%, x% Dim arr Dim Ws As Worksheet Set Ws = Sheets("EN") With Ws .Range("E1").CurrentRegion.Offset(1).ClearContents Set CoL = CreateObject("System.Collections.sortedlist") Lr = .Cells(Rows.Count, 1).End(3).Row For i = 2 To Lr CoL.Add Len(.Cells(i, 1)) + i / 1000, .Cells(i, 1) & _ "*" & .Cells(i, 2) Next i x = 2 For i = 0 To CoL.Count - 1 .Cells(x, "E") = Split(CoL.GetByIndex(i), "*")(0) .Cells(x, "F") = Split(CoL.GetByIndex(i), "*")(1) arr = Split(Split(CoL.GetByIndex(i), "*")(1), ",") .Cells(x, "G") = UBound(arr) + 1 x = x + 1 Next End With Set Ws = Nothing: Set CoL = Nothing End Sub الملف مرفق
    Hitari.xlsm
  18. سليم حاصبيا's post in الفرق بين عمودين was marked as the answer   
    فقط تغيير المعطيات
    Option Explicit '++++++++++++++++++++++++++++++ Dim Ra As Range, Rb As Range Dim a%, b%, i%, Bol As Boolean Dim m%, t% Dim Ky Dim S As Worksheet Dim Dic_Unique As Object Dim Dic As Object '++++++++++++++++++++++++++++++++++++++ Sub Item_Unique() Set S = Sheets("Salim") Set Dic = CreateObject("Scripting.Dictionary") Set Dic_Unique = CreateObject("Scripting.Dictionary") a = S.Cells(Rows.Count, 1).End(3).Row b = S.Cells(Rows.Count, 2).End(3).Row Set Ra = S.Range("A2:A" & a) Set Rb = Range("B2:B" & b) For i = 2 To b Dic_Unique(S.Cells(i, 2).Value) = "" Next End Sub '""""""""""""""""""""""""""""""""""""""""""" Sub ExtractB() Item_Unique S.Range("K2").CurrentRegion.Offset(1).ClearContents If Dic_Unique.Count Then For Each Ky In Dic_Unique.keys Bol = IsError(Application.Match(Ky, Ra, 0)) If Bol Then Dic(Ky) = 1 Else Dic(Ky) = Application.CountIf(Rb, Ky) - 1 End If Next Ky End If If Dic.Count Then m = 2 For Each Ky In Dic.keys If Dic(Ky) <> 0 Then S.Range("K" & m).Resize(Dic(Ky)) = Ky m = m + Dic(Ky) End If Next t = S.Range("k2").CurrentRegion.Rows.Count If t > 1 Then S.Range("L2") = t - 1 S.Range("J2").Resize(t - 1).Value = _ Evaluate("Row(1:" & t - 1 & ")") End If End If Set S = Nothing Set Ra = Nothing: Set Rb = Nothing Set Dic_Unique = Nothing Set Dic = Nothing End Sub الملف مرفق
    Alla_20_4.xlsm
  19. سليم حاصبيا's post in كود نقل اصفف على حسب اسم الشهر was marked as the answer   
    <رب هذا الملف
    Sub each_row_to_Its_sheet() Dim lr, i, x Dim sh As Worksheet Sheets("jan").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Feb").Range("a2").CurrentRegion.Offset(1).ClearContents Sheets("Mar").Range("a2").CurrentRegion.Offset(1).ClearContents With Sheets("Legal") lr = .Cells(Rows.Count, 1).End(3).Row For i = 3 To lr If Not IsDate(.Cells(i, 2)) Then GoTo next_i Select Case Month(.Cells(i, 2)) Case 1: Set sh = Sheets("jan") Case 2: Set sh = Sheets("Feb") Case 3: Set sh = Sheets("Mar") Case Else: GoTo next_i End Select x = sh.Cells(Rows.Count, 1).End(3).Row + 1 sh.Cells(x, 1).Resize(, 5).Value = _ .Cells(i, 1).Resize(, 5).Value next_i: Next i End With End Sub الملف مرفق
    Naser.xlsm
  20. سليم حاصبيا's post in مساعدة في طريقة البحث ببداية الاسم او باجزاء من الاسم كما في الصورة المرفقة was marked as the answer   
    الكود المطلوب
    Private Sub TextBox27_Change() Dim bol As Boolean If TextBox27.Value <> "" Then ListBox1.Visible = True Else ListBox1.Visible = False End If Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For i = 1 To 26 Controls("TextBox" & i).Text = "" Next i If TextBox27 = "" Then Exit Sub bol = Me.OptionButton1 = True If bol Then For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x Else For Each x In ThisWorkbook.Worksheets SS = x.Cells(Rows.Count, 2).End(xlUp).Row For Each c In x.Range("B2:B" & SS) If Trim(c) Like "*" & TextBox27 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 2) ListBox1.List(k, 1) = c.Worksheet.Name ListBox1.List(k, 2) = c.Row ListBox1.List(k, 3) = x.Name k = k + 1 End If Next c Next x End If End Sub الملف مرفق
    Allaq_User.xlsm
  21. سليم حاصبيا's post in استكمال عمل فاتورة استهلاك الكهرباء was marked as the answer   
    جرب هذا الملف
    الكود
    Option Explicit Function Elctric(Sm, n1, n2, n3, n4, n5, n6, n7) Dim x# If Sm <= 0 Then Elctric = 9 Exit Function End If Select Case Sm Case Is < 50: x = (50 - Sm) * n1 Case Is < 100: x = 50 * n1 + (Sm - 50) * n2 Case Is < 200: x = 50 * n1 + 50 * n2 + (Sm - 100) * n3 Case Is < 350: x = 50 * n1 + 50 * n2 + 100 * n3 + _ (Sm - 200) * n4 Case Is < 650: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + (Sm - 350) * n5 Case Is < 1000: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + (Sm - 650) * n6 Case Else: x = 50 * n1 + 50 * n2 + 100 * n3 + _ 200 * n4 + 350 * n5 + 650 * n6 + (Sm - 1000) * n7 End Select Elctric = x End Function الملف مرفق
    Electric.xlsm
  22. سليم حاصبيا's post in دمج كودين was marked as the answer   
    ربما هذا الكود
    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Large_RG As Range Dim Unique_RG As Range Dim Empty_String$, Other__String$ Dim Option_string$ Dim Position% Const m = 2 Empty_String = "": Other__String$ = "Hirassa" Set Large_RG = Range("Q9:Y300") Set Unique_RG = Range("G3") Dim q%, r%, S%, t%, u%, v%, W%, x%, y% q = 17: r = 18: S = 19: t = 20 u = 21: v = 22: W = 23: x = 24: y = 25 Application.EnableEvents = False If Not Intersect(Target, Unique_RG) Is Nothing _ And Target.Cells.Count = 1 Then Range("D8") = Other__String End If If Not Intersect(Target, Large_RG) Is Nothing _ And Target.Cells.Count = 1 Then Select Case Target.Column Case q: Option_string = Empty_String: Position = q - 2 * m Case r: Option_string = Empty_String: Position = r - 3 * m Case S: Option_string = Empty_String: Position = S - 4 * m Case t: Option_string = Empty_String: Position = t - 5 * m Case u: Option_string = Empty_String: Position = u - 6 * m Case v: Option_string = Empty_String: Position = v - 7 * m Case W: Option_string = Empty_String: Position = W - 8 * m Case x: Option_string = Empty_String: Position = x - 9 * m Case y: Option_string = Empty_String: Position = y - 10 * m End Select If Target = "a" Then Target.Offset(, Position) = Empty_String End If End If Application.EnableEvents = True End Sub الملف
     
    Joe_code.xlsm
  23. سليم حاصبيا's post in قائمة منسدلة نتحكم فيها من عدة اوراق عمل was marked as the answer   
    جرب هذا الملف
    Data_Val_Jo.xlsm
  24. سليم حاصبيا's post in تنشيط البحث برقم الفاتورة بداية من A2 وجعل الفروم يعمل ايضا عند قفل الـ protect sheet was marked as the answer   
    تم التعذيل على الماكروات
    Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Private Sub Fnd_change() Debut Dim R1%, R2% Me.ListBox1.RowSource = "" If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd & "*", Lookat:=2) If Not F Is Nothing Then R1 = F.Row: R2 = R1 Do With Me.ListBox1 .AddItem For i = 0 To .ColumnCount - 1 .List(.ListCount - 1, i) = sh.Cells(R2, 1).Offset(, i) Next Set F = sh.Range("A1:A" & Ro).FindNext(F) R2 = F.Row If R2 = R1 Then Exit Do End With Loop End If End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut Dim t% If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub t = Me.ListBox1.ListIndex Set F = sh.Range("A1:A" & Ro).Find(Me.ListBox1.List(t, 0), Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut Dim t%, st If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub t = Me.ListBox1.ListIndex st = Me.ListBox1.List(t, 0) Set F = sh.Range("A1:A" & Ro).Find(st, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete Me.ListBox1.RemoveItem (t) ListBox1.ListIndex = -1 For i = 0 To 6 Me.Controls(Arr_text(i)) = "" Next MsgBox "the Item " & """" & st & """" & Chr(10) & _ "with address " & """" & sh.Cells(K, 1).Resize(, 7).Address(0, 0) _ & """" & " Is Deleted", 64 Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف من جديد
    My_ListBox_1.xlsm
  25. سليم حاصبيا's post in انشاء كود ترحيل فاتورة was marked as the answer   
    جرب هذا الملف
    1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً)
      مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات)
    2- من المفروض اضافة القليل من البيانات في الأوراق العمل ولا تتكل على من يريد المساعدة للقيام بذلك
    3- تم وضع بعض المعادلات التي تساعد في ادراج النتائج (دون ظهور الأصفار)
    4- الصف رقم 6 في الاوراق Bay  و  Inport يجب ان يبقى فارغاً
    الكود
    Option Explicit Sub From_Sheets_To_MaG() Dim Inp As Worksheet, Bay As Worksheet Dim Mag As Worksheet Dim Sh As Worksheet Dim L_Mag%, Max_ro%, col%, k%, ro% Dim Fnd As Range, Wat As Range Dim Old_val Set Inp = Sheets("Inport") Set Bay = Sheets("Bay") Set Mag = Sheets("Magazine") L_Mag = Mag.Cells(Rows.Count, 1).End(3).Row Set Fnd = Mag.Range("A1:A" & L_Mag) If Not (ActiveSheet.Name = "Inport" Or _ ActiveSheet.Name = "Bay") Then Exit Sub Set Sh = ActiveSheet Select Case Sh.Name Case "Bay": col = 6 Case "Inport": col = 5 Case Else: Exit Sub End Select Max_ro = Application.Max(Sh.Range("B6:B68")) + 6 For k = 7 To Max_ro Set Wat = Fnd.Find(Sh.Range("E" & k), lookat:=1) If Not Wat Is Nothing Then ro = Wat.Row Old_val = Val(Mag.Cells(ro, 3)) Mag.Cells(ro, 7) = Old_val Mag.Cells(ro, col) = Val(Sh.Range("H" & k)) Mag.Cells(ro, 3) = _ Old_val + Val(Mag.Cells(ro, 5)) - Val(Mag.Cells(ro, 6)) End If Next End Sub الملف مرفق
    Hasan_B.xlsm
×
×
  • اضف...

Important Information