ماكرو VBA لنقل الخلايا إلى ورقة Excel جديدة بناءً على محتوى الخلية
سؤال
أنظر حولي ولم أتمكن من العثور على الاستجابة المحددة التي أحتاجها.لذلك سأطلب.لدي ورقة (ورقة 1) تحتوي على بيانات في العمود A فقط.تبدو هكذا:
وأحتاج إلى إنشاء ماكرو VBA الذي يبحث في العمود A عن أي خلية تحتوي على المعرف وTITL وAUTH.ونقلهم إلى عمود محدد في ورقة أخرى (ورقة 2).ستحتوي الورقة 2 على 3 أعمدة:الهوية والعنوان والمؤلف.
الشيء هو أنه بالإضافة إلى نسخ بيانات الخلية إلى عمودها المحدد في الورقة 2، فإنها تحتاج أيضًا إلى حذف الجزء الأول من البيانات.على سبيل المثال:بطاقة تعريف:يجب نقل R564838 في الورقة 1 إلى عمود المعرف في الورقة 2، بدون "المعرف:" فيه.لذلك يجب نقل R564838 فقط.يجب أيضًا إزالة "TITL:" و"AUTH:" عند نسخهما.
آمل أن يكون هذا الأمر يبدو معقولا تماما.أنا فقط أتعلم وحدات ماكرو VBA.لذلك ليس لدي أي فكرة عن كيفية تحقيق ذلك.
تحديث
لدي هذا الرمز:
Sub MoveOver()
Cells(1, 1).Activate
While Not ActiveCell = ""
If UCase(Left(ActiveCell, 4)) = " ID" Then Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell))) 'Move ID to Col A in sheet 2
If UCase(Left(ActiveCell, 4)) = "TITL" Then Sheets(2).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell))) 'Move TITL to Col B in sheet 2
If UCase(Left(ActiveCell, 4)) = "AUTH" Then Sheets(2).Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell))) 'Move AUTH to Col C in sheet 2
ActiveCell.Offset(1, 0).Activate
Wend
نهاية الفرعية
ويعمل.ولكن هناك بعض AUTH وTITL في الورقة 1 الفارغة.والموقف هو أنه عند تشغيل هذا، فإنه لا يترك خلية فارغة عندما يكون AUTH أو TITL فارغين.أحتاج إلى ترك الماكرو خلية فارغة إذا كان AUTH أو TITL فارغين بحيث تتطابق المعلومات مع كل كتاب.آمل أن تفهم مشكلتي.
شكرا مرة اخرى!
المحلول
قم بتعيين بعض المتغيرات للتأكد من أنك تعمل على المصنف/الورقة/العمود الصحيح
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
col = 1
ابحث عن الخلية الأخيرة في العمود
last1 = ws1.Cells(ws1.Rows.Count, col).End(xlUp).Row
انظر إلى كل خلية لتعرف ما يجب فعله بها
For x = 1 To last1
'What you do with each cell goes here
Next x
تقييم محتوى الخلية (معرفة ما إذا كانت تحتوي على شيء محدد)
If ws1.Cells(x, col) Like "*ID:*" Then
'What you do with a cell that has "ID:" in it
End If
استخراج محتوى الخلية محل الاهتمام (إزالة "الرأس")
myID = Mid(ws1.Cells(x, col), InStr(ws1.Cells(x, col), "ID:") + Len("ID:"))
ضع المحتوى في الصف التالي المتاح من الورقة الثانية (بافتراض أن المعرف موجود في العمود 1)
current2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row + 1
ws2.Cells(current2, 1) = myID
تعرف على كيفية تجميع أجزاء التعليمات البرمجية معًا وتكييفها لتناسب احتياجاتك المحددة!
ردا على تعليقك:
في الأساس، نعم، ولكن قد تواجه بعض المشاكل لأنها ليست شاملة تمامًا لموقفك الخاص.ما قد يتعين عليك فعله هو:
- قم بتخزين المعرف (بمجرد العثور عليه) في متغير؛
- افعل الشيء نفسه بالنسبة للعنوان والمؤلف؛
- بمجرد العثور على سطر محدد، يمكنك بدلاً من ذلك كتابة المحتوى الحالي للمتغيرات إلى السطر التالي المتاح وإفراغ محتوى تلك المتغيرات.
على سبيل المثال :
If ws1.cells(x, col) Like "*----*" Then
current2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row + 1
ws2.Cells(current2, 1) = myID
ws2.Cells(current2, 2) = myTitle
ws2.Cells(current2, 3) = myAuthor
myID = ""
myTitle = ""
myAuthor = ""
End If
ها أنت ذا :)
Sub MoveOver()
Cells(1, 1).Activate
myId = ""
myTitle = ""
myAuthor = ""
While Not ActiveCell = ""
If UCase(Left(ActiveCell, 4)) Like "*ID*" Then myId = Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell)))
If UCase(Left(ActiveCell, 4)) = "TITL" Then myTitle = Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell)))
If UCase(Left(ActiveCell, 4)) = "AUTH" Then myAuthor = Trim(Mid(ActiveCell, InStr(1, ActiveCell, ":") + 1, Len(ActiveCell)))
If ActiveCell Like "*---*" Then
'NOW, MOVE TO SHEET2!
toRow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Sheets(2).Cells(toRow, 1) = myId
Sheets(2).Cells(toRow, 2) = myTitle
Sheets(2).Cells(toRow, 3) = myAuthor
myId = ""
myTitle = ""
myAuthor = ""
End If
ActiveCell.Offset(1, 0).Activate
Wend
إذا كنت بحاجة إلى مساعدة في فهم ما قمت بتغييره، فأخبرني بذلك، ولكن ينبغي أن يكون ذلك واضحًا تمامًا!
نصائح أخرى
قد ترغب أيضا في محاولة القيام بنص إلى عمود مع A: كفاصل.من شأنها أن تعطي معلوماتك في أعمدة 2 بدلا من 1، ثم يمكنك البحث عن عمود واحد لرأس ونسخ قيمة الأعمدة التالية أو فارغة أو غير ذلك.