ماكرو VBA لنقل الخلايا إلى ورقة Excel جديدة بناءً على محتوى الخلية

Question

أنظر حولي ولم أتمكن من العثور على الاستجابة المحددة التي أحتاجها.لذلك سأطلب.لدي ورقة (ورقة 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 فارغين بحيث تتطابق المعلومات مع كل كتاب.آمل أن تفهم مشكلتي.

شكرا مرة اخرى!

Answer 1

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

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

تعرف على كيفية تجميع أجزاء التعليمات البرمجية معًا وتكييفها لتناسب احتياجاتك المحددة!

---

ردا على تعليقك:

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

1. قم بتخزين المعرف (بمجرد العثور عليه) في متغير؛
2. افعل الشيء نفسه بالنسبة للعنوان والمؤلف؛
3. بمجرد العثور على سطر محدد، يمكنك بدلاً من ذلك كتابة المحتوى الحالي للمتغيرات إلى السطر التالي المتاح وإفراغ محتوى تلك المتغيرات.

على سبيل المثال :

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

إذا كنت بحاجة إلى مساعدة في فهم ما قمت بتغييره، فأخبرني بذلك، ولكن ينبغي أن يكون ذلك واضحًا تمامًا!

Answer 2

قد ترغب أيضا في محاولة القيام بنص إلى عمود مع A: كفاصل.من شأنها أن تعطي معلوماتك في أعمدة 2 بدلا من 1، ثم يمكنك البحث عن عمود واحد لرأس ونسخ قيمة الأعمدة التالية أو فارغة أو غير ذلك.