Excel VBA Macro: Copying relative cell to another worksheet

问题

I am trying to fix missing entry by

finding it and then
copying the most left cell value relative to the found entry to the first empty bottom cell of another worksheet.

   With Worksheets("Paste Pivot").Range("A1:AZ1000")
   Dim source As Worksheet
   Dim destination As Worksheet
   Dim emptyRow As Long
   Set source = Sheets("Paste Pivot")
   Set destination = Sheets("User Status")
   Set c = .Find("MissingUserInfo", LookIn:=xlValues)
   If Not c Is Nothing Then
    firstAddress = c.Address
    Do
                   'Here would go the code to locate most left cell and copy it into the first empty bottom cell of another worksheet  
       emptyRow = destination.Cells(destination.Columns.Count, 1).End(xlToLeft).Row
       If emptyRow > 1 Then
       emptyRow = emptyRow + 1
       End If
       c.End(xlToLeft).Copy destination.Cells(emptyRow, 1)
        c.Value = "Copy User to User Status worksheet"

        Set c = .FindNext(c)
        If c Is Nothing Then Exit Do
    Loop While c.Address <> firstAddress
End If
End With

回答1:

I think CurrentRegion will help you here.

e.g. If you had a value in every cell in the range A1:E4 then

Cells(1,1).CurrentRegion.Rows.Count would equal 4 and

Cells(1,1).CurrentRegion.Columns.Count would equal 5

Therefore you can write:

c.End(xlToLeft).Copy _
    destination.Cells(destination.Cells(1).CurrentRegion.Rows.Count + 1, 1)

Provided you don't have any gaps in the middle of your destination spreadsheet, this will copy the user id from the beginning of the line with the "MissingUserInfo" (in the "Paste Pivot" sheet) to the first cell of a new row at the end of the "User Status" sheet.

Your Do Loop then becomes:

Do
    c.End(xlToLeft).Copy _
        destination.Cells(destination.Cells(1).CurrentRegion.Rows.Count + 1, 1)
    c.Value = "Copy User to User Status worksheet"
    Set c = .FindNext(c)
    If c Is Nothing Then Exit Do
Loop While c.Address <> firstAddress

回答2:

Answer as originally edited into the question by the original poster:

With Worksheets("Paste Pivot").Range("A1:AZ1000")
Dim source As Worksheet
Dim sourceRowNumber As Long
Dim destination As Worksheet
Dim destCell As Range
Dim destCellRow As Long
Set source = Sheets("Paste Pivot")
Set destination = Sheets("User Status")
Set c = .Find("MissingUserInfo", LookIn:=xlValues)
If Not c Is Nothing Then
    firstAddress = c.Address
    Do

      With destination
       Set destCell = .Cells(.Rows.Count, "A").End(xlUp)
       destCellRow = destCell.Row + 1
        End With

       sourceRowNumber = c.Row

       destination.Cells(destCellRow, 1).Value = source.Cells(sourceRowNumber, 1)
       destination.Cells(destCellRow, 2).Value = source.Cells(sourceRowNumber, 2)
       destination.Cells(destCellRow, 3).Value = source.Cells(sourceRowNumber, 3)

       c.Value = "Run Macro Again"

        Set c = .FindNext(c)
        If c Is Nothing Then Exit Do
    Loop While c.Address <> firstAddress
End If
End With

来源：https://stackoverflow.com/questions/16320352/excel-vba-macro-copying-relative-cell-to-another-worksheet

标签

excel

vba

find