简体   繁体   中英

Partial row copying from one sheet to another and mixed type data cell comparing

I have a working macro, that basically cuts row from base sheet, if values in rows fist cell (column A) matches a value in target sheets cell = B1, and to paste it in target sheets first empty row (checks cells in column A). But as the functionality of my Excel needs to be slightly changed, I need to make some adjustments, but all my attempts have failed so far.

Here is the working code:

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

And here are issues, which I'm dealing with:

Issue nr.1:

The code does not work if cell B1 contains mixed text and number and (dash/comma/space), for example: "white - 32". I've tried to use Variant, but it did not work correctly each time and made data sorting quite slower especially with large data amount.

Here I've tried to compare two cells with StrComp, the code itself didn't show any errors, but also did not do the thing that it should do - which is - copying data to target sheet:

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If StrComp(shBase.Cells(i, 1).Value, shtarget.Cells(1, 2).Value) = 0 Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

What am I missing?
Is there more efficient way to compare mixedtype data in cells?

Issue nr.2:

With the existing code, copying entire row interferes with data in target sheets right part of the page, as it is shifting rows down. But, it is necessary to cut/copy certain part of row (for example: from A2:J2) from base sheet and paste only data in target sheets region from A to J, while not messing up other part of the target sheet. It should act more like stepping 1 row down, not inserting and shifting rows, which is happening with the existing code.
I've tried substituting "EntireRow" with Range(A2:J2), but it only left me with necessary data missing and wrong data copying to my target sheet.

How to define specific Range of a row in code below to paste only data in target sheet, while not inserting new rows (and not messing up other data which is out of the target sheets A:J range)?

Sub RowCopy()

Application.ScreenUpdating = False

Set shtarget = Sheets("TargetSheet")

Set shBase = Sheets("BaseSheet")

For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1
    If shBase.Cells(i, 1).Value = shtarget.Cells(1, 2).Value Then
    shBase.Rows(i).EntireRow.Cut
    shtarget.Rows(shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Row + 1).EntireRow.Insert Shift:=xlDown
    shBase.Rows(i).EntireRow.Delete

End If

Next i

Application.CutCopyMode = False

Set shtarget = Nothing
Set shBase = Nothing

Application.ScreenUpdating = True

End Sub

I don't see any issues with searching for (eg) "white - 32"...

Sub RowCopy()

    Dim shtarget As Worksheet, shBase As Worksheet
    Dim vGet, cDest As Range, i As Long

    Application.ScreenUpdating = False

    Set shtarget = Sheets("TargetSheet")
    Set shBase = Sheets("BaseSheet")

    'get initial paste position
    Set cDest = shtarget.Cells(shtarget.Rows.Count, 1).End(xlUp).Offset(1, 0)
    'value being searched for
    vGet = shtarget.Cells(1, 2).Value

    For i = shBase.Range("A" & shBase.Rows.Count).End(xlUp).Row To 1 Step -1

        If shBase.Cells(i, 1).Value = vGet Then
            shBase.Cells(i, 1).Resize(1, 10).Copy cDest 'copy 10 columns
            shBase.Rows(i).EntireRow.Delete
            Set cDest = cDest.Offset(1, 0)
        End If

    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM