التفوق - نسخ الصف وإدراج مرات ن
القضية
أحاول إنشاء ماكرو ضمن Excel.
بياناتي هي كما يلي:
العمود 1 العمود 2 العمود 3 العمود 4
Data1 Data1 Name1 ؛ Name2 ؛ Name3 Data1
Data2 Data2 Name1 ؛ Name2 ؛ Data2
Data3 Data3 Name1 ؛ Name2 ؛ Name3 Data3
تحتوي كل خلية في العمود 3 على عدد من الأسماء مفصولة بفاصلة منقوطة.
أحتاج إلى ماكرو يقوم بهذه الأشياء:
1) قم بإنشاء عدد من الصفوف بعد الصف الأول. N هو عدد الأسماء في الخلية في أول العمود 3.
2) افصل الأسماء في الصفوف أدناه. (على غرار النص إلى الأعمدة)
3) نسخ محتوى الخلايا الأخرى في الصف الأصلي إلى الصفوف المدرجة أدناه.
4) انتقل إلى الصف التالي وافعل كل شيء مرة أخرى.
يجب أن تبدو النتيجة كما يلي:
العمود 1 العمود 2 العمود 3 العمود 4
Data1 Data1 Name1 Data1
Data1 Data1 Name2 Data1
Data1 Data1 Name3 Data1
Data2 Data2 Name1 Data2
Data2 Data2 Name2 Data2
Data3 Data3 Name1 Data3
Data3 Data3 Name2 Data3
Data3 Data3 Name3 Data3
هل تستطيع مساعدتي؟
حل
قم بتنزيل الملف "duffy.xlsm" من صفحة الويب هذه //speedy.sh/ruRSQ/duffy.xlsm.
البيانات الرئيسية موجودة في الورقة 1 (بدون فواصل منقوطة) وتكون النتيجة في الورقة 2.
يتم تكرار وحدات الماكرو هنا:
الاختبار الفرعي () Dim rrow1 As Range ، rrow2 As Range ، crow2 As String ، rcol As Range Dim j As Long، k As Long، nname () As String Dim m As Integer، dest As Range، ddata () As String، n As Long Application.ScreenUpdating = خطأ التراجع مع أوراق العمل ("sheet1") j = .Range ("a1"). End (xlDown) .Row ReDim ddata (1 إلى j - 1) For k = 2 To j ddata (k - 1) = .Cells (k ، Columns.Count). End (xlToLeft) .Value 'msgbox ddata (k - 1) Set rcol = Range (.Cells (k ، "C") ، .Cells (k ، "c" ). End (xlToRight) .Offset (0، -1)) msgbox rcol.Address m = WorksheetFunction.CountA (rcol) msgbox m ReDim nname (1 To m) For n = 1 إلى m nname (n) = rcol (1، n) 'msgbox nname (n) التالي n' msgbox rcol.Address Range (.Cells (k، "A")، .Cells (k، "B")). Copy with Worksheets ("sheet2") Set dest = .Cells (Rows.Count ، "A"). End (xlUp) .Offset (1، 0) 'msgbox dest.Address Range (dest، dest.Offset (m - 1، 0)). PasteSpecial For n = 1 إلى m dest.Offset (n - 1، 0) .Offset (0، 2) = nname (n) .Cells (dest.Offset (n - 1، 0) .Row، Columns.Count) .End (xlToLeft) .Offset (0 ، 1) = ddata (k - 1) Nex t n End بـ Next k End مع Application.ScreenUpdating = True Application.CutCopyMode = False MsgBox "macro over" End Sub Undo () أوراق العمل ("sheet2"). Cells.Clear End Sub بفضل venkat1926 لهذه النصيحة.