Copying rows through to another worksheet using criteria and VBA

alisun125 · #1 05-25-2016, 02:40 AM

Hello,

I am having problems writing a code to copy the rows from one worksheet to another, if certain criteria are met.

A data dump is taken from a report and copied into worksheet "a" (starting at C5 due to column headings etc), then in worksheet "b" I need to, on the pressing of a command button, delete the current data in worksheet "b" (C5:Z21000), and pull through data from worksheet "a" (C5:Z21000) if the code number in Column P ends with a ".99" (example code: AB.CD.01.99) and if Column S is NOT populated.

The reason for the deleting of data first is that the only the current/live ".99" rows need to be copied through, and if Column S is populated or the code number has changed, then the actions against the rows have been completed.

It is not essential, but would be super helpful if the code could only bring through Columns CDEFGHIPQRST and put them in CDEFGHIJKLMN.

Many thanks in advance.

alisun125

Philb1 · #2 06-01-2016, 03:05 AM

Try this
Sheet1 is the Data sheet where the new data is transferred to.
Sheet2 is the sheet where you paste the raw data dump.
The macro will transfer any row that has an empty cell in column S and on the same row in column P the text ends with .99
It takes columns C to I and columns P to T from the Dump sheet & pastes it into columns C to N on the Data sheet.

I think it's what you're after
Cheers

I wonder why this site doesn't like xlsb

Code:

Option Explicit

Sub CopyDataOver()

Dim AllData() As Variant, ColsC2I() As Variant, ColsP2T() As Variant
Dim Lrow As Long, A As Long, i As Long, j As Long
Dim str99 As String
str99 = ".99"

'   Clear the data sheet from row 5 down ready for new data
    If Not IsEmpty(Sheet1.Range("C5")) Then
        Sheet1.Range("C5:T" & Sheet1.Cells.Find(What:="*", LookIn:=xlValues, _
                    LookAt:=xlPart, Searchorder:=xlByRows, _
                    searchdirection:=xlPrevious, MatchCase:=False, searchformat:=False).Row).Clear
    End If

'   Find last used row of  data on The Dump sheet
    Lrow = Sheet2.Cells.Find(What:="*", LookIn:=xlValues, _
                LookAt:=xlPart, Searchorder:=xlByRows, _
                searchdirection:=xlPrevious, MatchCase:=False, searchformat:=False).Row
        
    If Lrow < 5 Then Lrow = 5 ' Prevent header being deleted etc

'   Count how many cells in Column P end with .99
    A = Application.WorksheetFunction.CountIf(Sheet2.Range("P5:P" & Lrow), "*" & str99)

ReDim AllData(1 To Lrow - 4, 1 To 18)
ReDim ColsC2I(1 To A, 1 To 7)
ReDim ColsP2T(1 To A, 1 To 5)

    AllData = Sheet2.Range("C5:T" & Lrow).Value2
    j = 1

    For i = LBound(AllData) To UBound(AllData)
    
'   If cell P5+ ends with .99 and cell S5+ is empty
        If Right(AllData(i, 14), Len(AllData(i, 14)) + 3 - Len(AllData(i, 14))) = str99 And IsEmpty(AllData(i, 17)) Then
        
            ColsC2I(j, 1) = AllData(i, 1): ColsC2I(j, 2) = AllData(i, 2): ColsC2I(j, 3) = AllData(i, 3)
            ColsC2I(j, 4) = AllData(i, 4): ColsC2I(j, 5) = AllData(i, 5): ColsC2I(j, 6) = AllData(i, 6)
            ColsC2I(j, 7) = AllData(i, 7)
            
            ColsP2T(j, 1) = AllData(i, 14): ColsP2T(j, 2) = AllData(i, 15): ColsP2T(j, 3) = AllData(i, 16)
            ColsP2T(j, 4) = AllData(i, 17): ColsP2T(j, 5) = AllData(i, 18)
            
            j = j + 1
            
        End If
    Next i

'   Paste 1st part of data on to Data sheet
    Sheet1.Range("C5").Resize(UBound(ColsC2I, 1), UBound(ColsC2I, 2)).Value2 = ColsC2I
'   Paste 2nd part of data on to Data sheet
    Sheet1.Range("J5").Resize(UBound(ColsP2T, 1), UBound(ColsP2T, 2)).Value2 = ColsP2T


Erase AllData
Erase ColsC2I
Erase ColsP2T

Exit Sub

End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
copy cells from a worksheet into other worksheets based on Criteria	Elton Wolter	Excel Programming	4	04-16-2016 08:44 AM
Trouble copying from one Worksheet to another	cengel63	Excel	0	03-19-2015 10:14 AM
Deleting rows with specific criteria	joflow21	Excel	9	11-22-2013 12:10 PM
Copying pivot table and graph to a new worksheet	artner0112	Excel	0	02-02-2013 07:19 PM
Worksheet copying?	markg2	Excel	4	01-07-2010 10:08 AM