简体   繁体   中英

Copy range to next available cell in different Worksheet

I'm working with an excel sheet that converts addresses from one format to another, pastes it in a sheet, and is then supposed to paste the correctly formatted addresses into the next available row in a master sheet of addresses that has thousands of records. There could be hundreds of addresses that need to be pasted to the master sheet, so I'm trying to avoid limiting my rows and ranges by specific references for example a range like ("A2:A6790") would not work because the lists can get long in both the conversion sheet and the master sheet. In the example below I use just one address but I need the code to be able to copy paste all the rows that have data (but not the header): 副本1 I need the highlighted row to copy to here: COPY2

I had to black out some of the addresses for privacy reasons, but I highlighted the row count to show how many records there are.

Here's my code:

`

Private Sub Convert()
Dim sap As Worksheet: Set sap = Sheets("SAP")
Dim con As Worksheet: Set con = Sheets("CONVERSION")
Dim abrv As Worksheet: Set abrv = Sheets("ABRV")
Dim slip As Worksheet: Set slip = Sheets("SLIP")
Dim ads As Worksheet: Set ads = Sheets("ADS")
Dim adsrng As Range: Set adsrng = ads.Range("B:B")
Dim conads As Range: Set conads = con.Range("W:W")
Dim saprngQW As Range: Set saprngQW = sap.Range("q:w")
Dim conrngOU As Range: Set conrngOU = con.Range("o:u")
Dim saprngDO As Range: Set saprngBO = sap.Range("B:O")
Dim conrngBN As Range: Set conrngBN = con.Range("B:N")
Dim sapcity2 As Range: Set sapcity2 = sap.Range("o:o")
Dim concity2 As Range: Set concity2 = con.Range("x:x")
Dim sapunion As Range: Set sapunion = Union(saprngQW, saprngBO)
Dim FndList, x&
    'Dim nextrow As Long
    'nextrow = slip.Cells(Rows.Count, "A").End(xlUp).Row + 1

    'Dim pasteslip As Range: Set pasteslip = slip.Range("A" & nextrow)

sap.Select
sapunion.Copy

con.Select
con.Range("a:a").PasteSpecial xlPasteValues

sap.Select
sapcity2.Copy

con.Select
concity2.PasteSpecial xlPasteValues

adsrng.Copy

con.Select
conads.PasteSpecial xlPasteValues

FndList = abrv.Cells(1, 1).CurrentRegion
For x = 1 To UBound(FndList)
    con.Cells.Replace What:=FndList(x, 1), Replacement:=FndList(x, 2),    LookAt:=xlWhole, MatchCase:=True
Next

    con.Select
    con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)


        's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes *this 
         was a different approach I was going to try if there's no way to 
         fix things*
        'it comes from this code:
            'Sub CopyUnique()
                'Dim s1 As Worksheet, s2 As Worksheet
                'Set s1 = Sheets("Main")
                'Set s2 = Sheets("Count")
                's1.Range("B:B").Copy s2.Range("a" & nextrow)
                's2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
            'End Sub

End Sub

`

I commented out some of the code I tried using before (I kept getting paste area is out of range). The error I'm getting now is: Run-time error '1004': Method 'Range' of object'_Worksheet' failed , when it gets to this line con.Range("a:x").Copy slip.Range("A:X" & Rows.Count).End(xlUp).Offset(1, 0)

Any ideas what I can do? I feel like I'm so close but there's something obvious staring me in the face that I can't see.

Figured it out! Adapted some code I used for another project. Wasn't able to get it to skip copies but it works!

Dim ldestlRow As Long, i As Long
Dim ins As Variant
Dim h As String, won As String
Dim wo As Range    
    ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
    ins = con.UsedRange
    For i = 2 To UBound(ins)
        won = ins(i, 7)
        Set wo = Range("W2:W" & ldestlRow).Find(what:=won)
        If wo Is Nothing Then
            ldestlRow = slip.Cells(Rows.Count, 1).End(xlUp).Row + 1
            con.Range("A" & i).EntireRow.Copy slip.Range("A" & ldestlRow)
        End If 

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