[英]VBA macro to move cells to a new sheet and removing cell headers in Excel
[英]VBA macro to move cells to a new sheet Excel based on cell content
我環顧四周,找不到我需要的具體回復。 所以我會問。 我有一個工作表(sheet1),其數據僅在列A上。它看起來像這樣:
我需要創建一個VBA宏,該宏在A列中搜索包含ID,TITL和AUTH的任何單元格。 並將它們移動到另一個工作表(sheet2)中的特定列。 Sheet2將包含3列:ID,標題和作者。
事實是,將單元格數據復制到sheet2中的特定列的同時,還需要刪除數據的第一部分。 例如:工作表1中的ID:R564838需要移到工作表2中的ID列,而其中沒有“ 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
結束子
而且有效。 但是sheet1中有一些AUTH和TITL是空白的。 情況是,當它運行時,只要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:"))
將內容放在第二張工作表的下一個可用行中(假設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
如果您需要幫助以了解我的更改,請告訴我,但這應該很簡單!
您可能還想嘗試使用以:為分隔符的文本到列。 這將使您的信息分成2列而不是1列,然后您可以在一列中搜索標題,然后復制下一個列的值(空白或其他)。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.