Copy rows to a given sheet based on several criteria

[bfora]

I've been looking for a solution for this, but couldn't find the right one (or ones to combine).

I have a sheet containing information.

Criteria 1. Column D contains a date of service. As soon as a date is entered in this column, it means the service has taken place and the row can be copied to the given servicesheet (see criteria 2).

Criteria 2. Column A contains a servicename, corresponding the sheet where the entire row has to be copied to. This column will basically be blank, and has to be chosen by the user by drop down menu. If a date is entered, and no servicename is given, an error should occur (if possible the error should occur after finishing the correct input).

3. Both columns (A and D) can contain blanks. To define to last row (if needed) column H can be mentioned (every used row will contain a value).

4. There are 20 (or so) different services, and 20 different sheets for these. For non existing services (sheets) an error should occur.

Summarized: If a date and service is entered, the row has to be copied (and deleted from origin) to the sheet mentioned in column A, to the first blank row of that sheet.

Thanks in advance!

 

[RoryA]

Cross posted here and here.

 

[hippiehacker]

for what i understood this should work

Sub BFORA()
lastrow = ActiveSheet.Range("H" & Rows.Count).End(xlUp).Row
For i = lastrow To 1 Step -1
If Cells(i, "D") <> "" And Cells(i, "A") <> "" Then
sheetfound = 0
 For Each Sh In ThisWorkbook.Sheets
   If Cells(i, "A") = Sh.Name Then
    lastcell = Sheets(Sh.Name).Range("H" & Rows.Count).End(xlUp).Row
    Cells(i, 1).EntireRow.Copy Sheets(Sh.Name).Range("A" & lastcell + 1)
    Cells(i, 1).EntireRow.Delete
    sheetfound = 1
    End If
  Next Sh
  If sheetfound = 0 Then MsgBox "sheet " & Cells(i, 1).Value & " not found"
End If

Next i
End Sub

 

[bfora]

@RoryA: Thanks for adding the cross posts. I will do it myself if crossposting again...

@HippieHacker: Really great! Works exactly as I wished, including the error alert. Modified only one condition to IsDate(Cells(i, "D")). Thanks a lot. When reading, I just don't get why the script is counting the Sheets (For Each Sh In ThisWorkbook.Sheets) but basically counts the rows in ActiveSheet in the For/Next loop. Would be great to understand the whole code. Anyway, thanks a lot for this one!

A follow-up script for this one is asked here.

 

[hippiehacker]

with explanation:

Sub BFORA()
'get last populated row in column H on active sheet
lastrow = ActiveSheet.Range("H" & Rows.Count).End(xlUp).Row
'looping backward from lastrow to firstrow this is easier to handle the delete row later on
For i = lastrow To 1 Step -1
' if statements of your conditions to check
If Cells(i, "D") <> "" And Cells(i, "A") <> "" Then
'set sheetfound to 0 to be used later on to check if Sheet can be found from Sheetvalue in Column A
sheetfound = 0
' looping through the Worksheets in the workbook to see if the Sheet from Column A of current row i can be found
' if found then we copy the row to this sheet
 For Each Sh In ThisWorkbook.Sheets
  ' if sheetname matching the cell value of column A row i then:
   If Cells(i, "A") = Sh.Name Then
   'look for lastcell of the Sheet where we want to copy the row to
    lastcell = Sheets(Sh.Name).Range("H" & Rows.Count).End(xlUp).Row
    'copy the row
    Cells(i, 1).EntireRow.Copy Sheets(Sh.Name).Range("A" & lastcell + 1)
    'delete the row
    Cells(i, 1).EntireRow.Delete
    'set sheetfound to 1 will be used later on
    sheetfound = 1
    End If
  Next Sh
  'if the sheet could not be found we will populate an message box
  If sheetfound = 0 Then MsgBox "sheet " & Cells(i, 1).Value & " not found"
End If

Next i
End Sub

 

[bfora]

Thanks again!

 

[bfora]

For further use, the next adjustment is needed to avoid errors (copying unintended lines that do not meet both criteria).

Sub BFORA()
lastrow = ActiveSheet.Range("H" & Rows.Count).End(xlUp).Row
For i = lastrow To 1 Step -1
If Cells(i, "D") <> "" And Cells(i, "A") <> "" Then
sheetfound = 0
 For Each Sh In ThisWorkbook.Sheets
   If Cells(i, "A") = Sh.Name Then
    lastcell = Sheets(Sh.Name).Range("H" & Rows.Count).End(xlUp).Row
    Cells(i, 1).EntireRow.Copy Sheets(Sh.Name).Range("A" & lastcell + 1)
    Cells(i, 1).EntireRow.Delete
    sheetfound = 1
    Exit For
    End If
  Next Sh
  If sheetfound = 0 Then MsgBox "sheet " & Cells(i, 1).Value & " not found"
End IfNext i
End Sub

(Change made with the Exit For on 2/3 of the code.)