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

[mody200]

Private Sub b_recup_Click()
On Error Resume Next
Dim Y As Date
 Dim X As Integer
    Set fS = Sheets("تصدير بيانت اكسيل")
        For X = 0 To ListBox1.ListCount - 1
        Ligs = fS.Range("A" & Rows.Count).End(xlUp)(2).Row
  fS.[A2:l10000].ClearContents
 r1 = Text_count.Value
 Sheet5.Range("a2:L3999").ClearContents
hrd1 = Array("رصيد اول مدة")
fS.[c2].Resize(1, 1) = hrd1
fS.Range("f2") = ("بيان رصيد اول مدة بتاريخ هذا اليوم")
fS.Range("g2") = Text_count
fS.Range("i2") = Text_count
fS.Range("b2") = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy")
  a = Me.ListBox1.List
  fS.[A3].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
  c = 0
  For c = 1 To Irow
     fS.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c)
  Next
        fS.Range("F" & Ligs) = ("اجمالى")
        fS.Range("g" & Ligs) = TextBox3
        fS.Range("h" & Ligs) = TextBox2
        fS.Range("i" & Ligs) = TextBox1
    Next X
 ' f2.Cells.EntireColumn.AutoFit
  fS.Columns(13).ClearContents
  MsgBox "تم تصدير البيانات بنجاح"
 
 Unload Me
 Set Rng = fS.Range("A1").CurrentRegion
  fS.PageSetup.PrintArea = Rng.Address
  fS.PrintPreview
  fS.Zoom
  End Sub

 

Copy of كشف حساب عميل & كارت صنف.xlsm

تم تعديل يوليو 23 بواسطه mody200

[lionheart]

 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

 

[mody200]

انه يقوم بتصدير البينات بالفعل ولاكن يوجد فراغات بين البيانات وبين اجمالى القيم واجمالى قيم كل عمود كما هو موضح فى الصورةاريد القيم تكون فى اخر البيانات بدون فراغات

[mahmoud nasr alhasany]

جميل حقا

تم تعديل يوليو 24 بواسطه mahmoud nasr alhasany

[mody200]

الرجاء المساعدة بالنسبة للكود والفراغات عند كل عملية تصدير

[mahmoud nasr alhasany]

Private Sub b_recup_Click()
On Error Resume Next
Dim Y As Date
 Dim X As Integer
    Set fS = Sheets("تصدير بيانات اكسيل")
      fS.Rows("3:3999").Select
    Selection.Delete Shift:=xlUp
  fS.[a2:m3999].ClearContents
 r1 = Text_count.Value
 Sheet3.Range("a2:m3999").ClearContents
  
hrd1 = Array("رصيد اول مدة")
fS.[c2].Resize(1, 1) = hrd1
fS.Range("f2") = ("بيان رصيد اول مدة بتاريخ هذا اليوم")
fS.Range("g2") = Text_count
fS.Range("i2") = Text_count
fS.Range("b2") = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy")
  a = Me.ListBox1.List
  fS.[A3].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a
  c = 0
  For c = 1 To Irow
     fS.Cells(1, c) = Range(NomTableau).Offset(-1).Item(1, c)
      
  Next
  Ligs = fS.Range("A" & Rows.Count).End(xlUp)(2).Row
        fS.Range("f" & Ligs) = ("اجمالى")
        fS.Range("g" & Ligs) = TextBox3
        fS.Range("h" & Ligs) = TextBox2
        fS.Range("i" & Ligs) = TextBox1
 ' f2.Cells.EntireColumn.AutoFit
  fS.Columns(13).ClearContents
  MsgBox "تم تصدير البيانات بنجاح"
 
 Unload Me
 Set Rng = fS.Range("A1").CurrentRegion
  fS.PageSetup.PrintArea = Rng.Address
  fS.PrintPreview
  fS.Zoom
  End Sub

تم عمل المطلوب

جرب هذا الكود

تم تعديل يوليو 24 بواسطه mahmoud nasr alhasany

[محمد هشام.]

تفضل جرب هدا

Private Sub b_recup_Click()
Dim Cnt As VbMsgBoxResult
Dim sht As Worksheet, tbl As ListObject, tblRow As ListRow
Set sht = Sheets("تصدير بيانات اكسيل")
Set tbl = sht.ListObjects("Table1")
Cnt = MsgBox(" تــرحيل البيانات  ؟", vbYesNo, sht.Name): If Cnt <> vbYes Then Exit Sub
  With tbl.DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
  End With
  tbl.DataBodyRange.Rows(1).ClearContents
    Set tblRow = tbl.ListRows.Add
    tblRow.Range.Resize(Me.ListBox1.ListCount) = Me.ListBox1.List

sht.[b2] = Format(DateAdd("d", -1, CDate(Me.DateMini.Value)), "dd/mm/yyyy")
sht.[C2] = ("رصيد المدة"): sht.[F2] = ("بيان رصيد أول مدة بتاريخ هذا اليوم")
sht.[G2] = Text_count: sht.[I2] = Text_count
    
With sht.Cells(sht.Rows.Count, 6).End(xlUp).Offset(1)
    .Value = "الإجمالي"
    .Offset(, 1) = Me.TextBox3.Value
    .Offset(, 2) = Me.TextBox2.Value
    .Offset(, 3) = Me.TextBox1.Value
End With
MsgBox "تم نرحيــل البيانات بنجاح"
Unload Me
On Error Resume Next
Set Rng = sht.Range("A1").CurrentRegion
  sht.PageSetup.PrintArea = Rng.Address
  sht.PrintPreview
'  answer = MsgBox("طباعــة التقرير ؟", vbQuestion + vbYesNo + vbDefaultButton2, "تأكـــيد")
'    If answer = vbYes Then sht.PrintOut
  End Sub

تمت اظافة اكواد تصدير الملف بصيغة Word, Excel, PDF في الملف المرفق 

 

 

Copy of كشف حساب عميل & كارت صنف V5.xlsm

تم تعديل يوليو 25 بواسطه محمد هشام.

[mody200]

احسنت السيد محمد هشام انت بجد روعه ومنقذ