VBA macro to move cells to a new sheet Excel based on cell content

Question

I look around and could not find the specific response I need. So I will ask. I have a sheet (sheet1) with data only on column A. It looks like this:

And I need to create a VBA macro that searches in column A for any cell that contains ID, TITL, and AUTH. And move them to a specific column in another sheet(sheet2). Sheet2 will have 3 columns: ID, Title and Author.

The thing is that along with copying the data of the cell to its specific column in sheet2, it also needs to delete the first part of the data. For example: ID: R564838 in sheet1 needs to be moved to the ID column in sheet2, without the "ID:" in it. So only R564838 would need to be moved. Also "TITL:" and "AUTH:" would need to be removed when copied.

I hope this makes sense. I am just learning VBA macros. So I have no idea how to accomplish this.

UPDATE

I have this code:

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 

End Sub

And it works. But there are some AUTH and TITL in sheet1 that are blank. And the situation is that when this runs, it doesn't leave a empty cell whenever AUTH or TITL are blank. I need the macro to leave an empty cell if AUTH or TITL are blank so the information matches for each book. I hope you understand my issue.

Thank you again!

Answer 1

Set some variables to make sure you're working on the right workbook/sheet/column

Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
col = 1

Find the last cell of the column

last1 = ws1.Cells(ws1.Rows.Count, col).End(xlUp).Row

Look at each cell to figure out what to do with it

For x = 1 To last1
    'What you do with each cell goes here
Next x

Evaluate the content of the cell (Know if it contains something specific)

If ws1.Cells(x, col) Like "*ID:*" Then
    'What you do with a cell that has "ID:" in it
End If

Extract the content of interest of the cell (remove the "header")

myID = Mid(ws1.Cells(x, col), InStr(ws1.Cells(x, col), "ID:") + Len("ID:"))

Place the content in the next available row of second sheet (assuming ID goes in column 1)

current2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row + 1
ws2.Cells(current2, 1) = myID

Figure out how to put the bits of code together and adapt it to your exact needs!

---

In answer to your comment :

Basically, yes, but you might bump into some trouble as it's not fully comprehensive of your particular situation. What you might have to do is :

1. Store the ID (once you find one) in a variable;
2. Do the same for the title and author;
3. Once you find a delimiting line, you instead write the current content of the variables to the next available line and empty the content of those variables.

For example :

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

---

Here you go :)

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

If you need help understanding what I changed, let me know, but it should be pretty straight forward!

Answer 2

You might also want to try doing a text to column with a : as the separator. That would give your information in 2 columns instead of 1, then you could search one column for the header and copy the next column value, blank or otherwise.