Макрос VBA для перемещения клеток в новый лист Excel на основе содержания клетки

Question

Я оглянюсь вокруг и не смог найти конкретный ответ, который мне нужен. Так что я спрошу. У меня есть лист (лист1) с данными только на столбце A. Похоже, это выглядит:

И мне нужно создать макрос VBA, который ищет в столбце A для любой ячейки, которая содержит ID, Titl и Auth. И переместить их в определенный столбец в другом листе (листе2). Лист2 будет иметь 3 столбца: идентификатор, заголовок и автор.

Дело в том, что наряду с копированием данных ячейки к его определенному столбцу в листе2 также необходимо удалить первую часть данных. Например: ID: R564838 в листе1 должен быть перемещен в столбец ID в листе2, без «ID:» в нем. Поэтому только 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 

.

конец sub

и это работает. Но есть некоторые 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, то вы можете найти один столбец для заголовка и скопировать следующее значение столбца, пустое или иное.