مساعدة في ترحيل البيانات المسجلة في الخلايا واستثناء الخلايا الفارغة عن طريق فيجول بيسك

[القول المأثور]

مرحبا بالجميع

لدي بيانات تم إنشاء قائمة منسدلة بالطلبات في كل خلية في عمود الصنف، بحيث يتم ترحيلها إلى ورقة عمل أخرى. عند الضغط على مربع (ترحيل)

 أريد فقط عند ترحيل البيانات التي تم تسجيل بيانات بها، وعدم ترحيل باقي الصفوف الأخرى الفارغة.

مرفق ملف الأكسل 

عدم ترحيل البيانات الفارغة.xlsm

[سليم حاصبيا]

جرب هذا الماكرو

Sub MoveDataTOTable()
Dim endrow%, n%, MAX_RO%, K%
Dim M As Worksheet, D As Worksheet

Set M = Sheets("Main")
Set D = Sheets("DB")
 endrow = 1
 MAX_RO = M.Range("B9").CurrentRegion.Rows.Count
 D.Range("A1").CurrentRegion.Offset(1).ClearContents
If MAX_RO = 1 Then Exit Sub
 For K = 10 To MAX_RO + 10
If M.Cells(K, 2) <> "" Then
 n = n + 1
 D.Cells(endrow + 1, 4).Resize(, 4).Value = _
 M.Cells(K, 2).Resize(, 4).Value
 endrow = endrow + 1
 End If
Next
If n Then
With D.Cells(2, 2).Resize(n)
 .Value = M.Range("C6")
 .Offset(, 1) = M.Range("C7")
 .Offset(, -1) = Evaluate("Row(1:" & n & ")")
End With

D.Cells(2 + n, 5) = "TOTAL"
D.Cells(2 + n, 7).Formula = _
  "=SUM(G2:G" & n + 1 & ")"
  End If
End Sub

الملف مرفق

KOUL.xlsm

[القول المأثور]

  شاكر لك أخي سليم حاصبيا على الكود ، مع العلم عند اضافة بيانات جديدة يقوم الكود باستبدال البيانات المرحلة سابقاً واستبدالها بالبيانات الجديدة.

 حبذا لو أمكن اضافة البيانات السابقة مع البيانات الجديدة وعدم الحذف أو اسبتدالها، اضافة إلى ذلك ترحيل الملاحظات كما في المثال الذي ارفقته في مشاركتي الأولى.

وجزاك الله خيرا

[سليم حاصبيا]

تم التعديل كما تريد

Option Explicit
Sub Data_Without_Empty()
Dim endrow%, n%, MAX_RO%, K%
Dim M As Worksheet, D As Worksheet
Dim Fixed_row%, New_ro%
Set M = Sheets("Main")
Set D = Sheets("DB")
 endrow = D.Cells(Rows.Count, "E").End(3).Row

 Fixed_row = endrow + 1

 MAX_RO = M.Range("B9").CurrentRegion.Rows.Count

If MAX_RO = 1 Then Exit Sub
 For K = 10 To MAX_RO + 7
If M.Cells(K, 2) <> "" Then
 n = n + 1
 D.Cells(endrow + 1, 5).Resize(, 4).Value = _
 M.Cells(K, 2).Resize(, 4).Value
 endrow = endrow + 1
 End If
Next
If n Then
With D.Cells(Fixed_row, 3).Resize(n)
 .Value = M.Range("C6")
 .Offset(, 1) = M.Range("C7")
 .Offset(, 6) = M.Range("C25")
 .Offset(, -1) = Evaluate("Row(1:" & n & ")")
End With

D.Cells(n + Fixed_row, 5) = "TOTAL"
D.Cells(n + Fixed_row, 8).Formula = _
  "=SUM(H" & Fixed_row & ":H" & Fixed_row + n - 1 & ")"
 New_ro = D.Cells(Rows.Count, 2).End(3).Row
 D.Cells(2, 1).Resize(New_ro - 1).Formula = _
 "=IF(B2="""","""",MAX($A$1:A1)+1)"
 D.Cells(1, 1).CurrentRegion.Value = _
 D.Cells(1, 1).CurrentRegion.Value
  End If
End Sub

الملف من جديد

KOUL _1.xlsm

[القول المأثور]

بارك الله فيك عزيزي سليم على مساعدتك، مثل ما طلبت، لك جزيل الشكر والإمتنان