首页 文章

VBA宏根据单元格内容将单元格移动到新工作表Excel

提问于
浏览
0

我环顾四周,无法找到我需要的具体反应 . 所以我会问 . 我有一张表(sheet1),其数据仅在A列上 . 它看起来像这样:

enter image description here

我需要创建一个VBA宏,在A列中搜索包含ID,TITL和AUTH的任何单元格 . 并将它们移动到另一张纸(sheet2)中的特定列 . Sheet2将有3列:ID, Headers 和作者 .

问题是,除了将单元格的数据复制到sheet2中的特定列之外,还需要删除数据的第一部分 . 例如:ID:Sheet1中的R564838需要移动到sheet2中的ID列,而不包含“ID:” . 所以只需要移动R564838 . 复制时还需要删除“TITL:”和“AUTH:” .

我希望这是有道理的 . 我只是在学习VBA宏 . 所以我不知道如何做到这一点 .

UPDATE

我有这个代码:

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为空,我需要宏留空单元格,以便每本书的信息匹配 . 我希望你理解我的问题 .

再次感谢你!

2 回答

  • 2

    设置一些变量以确保您正在处理正确的工作簿/工作表/列

    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
    

    提取单元格感兴趣的内容(删除“ Headers ”)

    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
    

    弄清楚如何将代码位放在一起并根据您的确切需求进行调整!


    In answer to your comment :

    基本上,是的,但是你可能遇到一些麻烦,因为它并不完全全面地解决你的特殊情况 . 你可能需要做的是:

    • 在变量中存储ID(一旦找到);

    • 为 Headers 和作者做同样的事情;

    • 找到分隔线后,您可以将变量的当前内容写入下一个可用行并清空这些变量的内容 .

    例如 :

    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
    

    如果你需要帮助了解我改变了什么,请告诉我,但它应该是非常直接的!

  • 0

    您可能还想尝试使用:作为分隔符对列进行文本操作 . 这将使您的信息分为2列而不是1,然后您可以在一列中搜索 Headers 并复制下一列值,空白或其他 .

相关问题