VBA - Copy into other sheets based on keyword

[bvherrera]

Hello everyone!

For my line of work I work with lots of data (currently 10,000+ cells over 7 columns and counting!). Unfortunately, I am no good with VBA.

I had the following code made for me by the helpful elmer007:

Public Sub CopyRows()

'Counts for number of rows on Sheet2 and Sheet3
Dim dCount, rCount As Long
wCount = Application.WorksheetFunction.CountA(Sheets("TRANSF").Range("A:A"))
aCount = Application.WorksheetFunction.CountA(Sheets("SURPLUS").Range("A:A"))
sCount = Application.WorksheetFunction.CountA(Sheets("LOST").Range("A:A"))
dCount = Application.WorksheetFunction.CountA(Sheets("NO CMDB").Range("A:A"))


'Range to be used to traverse data on Sheet1
Dim myRange As Range
Set myRange = Sheets("Sheet1").Range("A1")




'Check every row until an empty row
Do Until IsEmpty(myRange)


    'If disposed, put values on Sheet2
    If InStr(1, UCase(myRange.Offset(0, 4)), "TRANSF") Then
        Sheets("TRANSF").Cells(wCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        wCount = wCount + 1
    End If
    
    'If respon party, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "SURPLUS") Then
        Sheets("SURPLUS").Cells(aCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        aCount = aCount + 1
    End If
    
        'If not found, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "LOST") Then
        Sheets("LOST").Cells(sCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        sCount = sCount + 1
    End If
    
        'If respon party, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "NO CMDB") Then
        Sheets("NO CMDB").Cells(dCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        dCount = dCount + 1
    End If
    
    'Move range down one row
    Set myRange = myRange.Offset(1, 0)
    
Loop


End Sub

The problems:

1. Currently, this code copies columns A-G into the specified sheet. I want only columns E-G copied over
2. I want the information copied to start on the second line, as opposed to the first, to be able to put headers over the data.
3. When the code ends, it copies the last 4 rows of data after the final keyword-containing row, regardless of the specific data in them.
4. Is there any way to copy over the rows that have any character, number, or phrase in column E, regardless of what it is, into a new sheet labeled "Not Found"?

Attached are examples of what it looks like currently, and what I want it to look like (minus headers in the other sheets). https://drive.google.com/file/d/0B3wQulJjDPsnYnVZanM5TS1nYlk/view?usp=sharing

Thank you all!

 

[Rhodie72]

This might be the solution:

Public Sub CopyRows()

'Counts for number of rows on Sheet2 and Sheet3
Dim dCount, rCount As Long, myRange As Range
With Application.WorksheetFunction
    wCount = .CountA(Sheets("TRANSF").Range("A:A"))
    aCount = .CountA(Sheets("SURPLUS").Range("A:A"))
    sCount = .CountA(Sheets("LOST").Range("A:A"))
    dCount = .CountA(Sheets("NO CMDB").Range("A:A"))
End With

'Range to be used to traverse data on Sheet1
Set myRange = Sheets("Sheet1").Range("G2")




'Check every row until an empty row
Do Until IsEmpty(myRange)


    'If disposed, put values on Sheet2
    If InStr(1, UCase(myRange.Offset(0, 4)), "TRANSF") Then
        Sheets("TRANSF").Cells(wCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        wCount = wCount + 1
    End If
    
    'If respon party, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "SURPLUS") Then
        Sheets("SURPLUS").Cells(aCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        aCount = aCount + 1
    End If
    
        'If not found, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "LOST") Then
        Sheets("LOST").Cells(sCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        sCount = sCount + 1
    End If
    
        'If respon party, put values on Sheet3
    If InStr(1, UCase(myRange.Offset(0, 4)), "NO CMDB") Then
        Sheets("NO CMDB").Cells(dCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value
        dCount = dCount + 1
    End If
    
    'Move range down one row
    Set myRange = myRange.Offset(1, 0)
    
Loop


End Sub

 

[Peter_SSs]

1. Currently ..
   
2. I want the information copied to start on the second line, as opposed to the first, to be able to put headers over the data.
   Does this refer to 'TRANSF', 'SURPLUS' etc? Do they already contain data? If so, does this mean it should be cleared first? Or should the current code append data at the end of each of these sheets?
   
3. When the code ends, it copies the last 4 rows of data after the final keyword-containing row, regardless of the specific data in them.
   Are you saying that the current code does this but you don't want it to happen?
   
4. Is there any way to copy over the rows that have any character, number, or phrase in column E, regardless of what it is, into a new sheet labeled "Not Found"?

Questions in red above.

 

[bvherrera]

This code isn't doing anything?

 

[bvherrera]

Questions in red above.

Peter_SSs,

For 2:
This refers to each sheet in the workbook. These sheets are Sheet1, TRANSF, SURPLUS, LOST, and NO CMDB. They do not contain data, as I want the data from Sheet1 to be transferred over to one of the other sheets, based on the specified keyword.
For 4:
Yes, the current code keeps going when no more key words are found for 4 rows, and copies said information regardless of data in them. I do not want it to do this.

 

[bvherrera]

PM
Rhodie72 and Peter_SSs,

Thank you both for your time and help so far!

 

[Peter_SSs]

Peter_SSs,

For 2:
This refers to each sheet in the workbook. These sheets are Sheet1, TRANSF, SURPLUS, LOST, and NO CMDB. They do not contain data, as I want the data from Sheet1 to be transferred over to one of the other sheets, based on the specified keyword.

My reading of point 4 in post #1 is that you also want a sheet called "NOT FOUND" and for it to include any rows from Sheet1 that includes data in column E that doesn't take it to one of the other 4 results sheets. If that is so, then try this in a copy of your workbook.

a) Make sure that as well as 'Sheet1' with the original data, you have sheets named 'TRANSF", 'SURPLUS', 'LOST', 'NO CMDB' and 'NOT FOUND'.
b) On each of the 5 results sheets, enter the required headings in columns A:C. If these are to just be the headings from columns E:G of Sheet1, then post back and the code could be modified to do that for you.
c) Run the following code. (Make sure that you include the 'Option Compare Text' line at the top of the module.

Option Compare Text

Sub SplitData()
  Dim aData As Variant, aResults As Variant, aRws As Variant, aShts As Variant
  Dim i As Long, j As Long, k As Long, rws As Long
  
  aShts = Split("TRANSF,1,,SURPLUS,1,,LOST,1,,NO CMDB,1,,NOT FOUND,1,", ",")
  With Sheets("Sheet1")
    aData = .Range("E2", .Range("G" & .Rows.Count).End(xlUp)).Value
  End With
  rws = UBound(aData)
  aRws = Evaluate("row(2:" & rws & ")")
  ReDim aResults(1 To rws, 1 To UBound(aShts) + 1)
  For j = 1 To UBound(aResults, 2) Step 3
    aResults(1, j) = aShts(j - 1)
    aResults(1, j + 1) = aShts(j)
  Next j
  For i = 1 To rws
    Select Case True
      Case InStr(1, aData(i, 1), "transf"): k = 2
      Case InStr(1, aData(i, 1), "surplus"): k = 5
      Case InStr(1, aData(i, 1), "lost"): k = 8
      Case InStr(1, aData(i, 1), "no cmdb"): k = 11
      Case aData(i, 1) <> vbNullString: k = 14
    End Select
    aResults(1, k) = aResults(1, k) + 1
    For j = 1 To 3
      aResults(aResults(1, k), k + j - 2) = aData(i, j)
    Next j
  Next i
  For j = 1 To UBound(aResults, 2) Step 3
    With Sheets(aResults(1, j))
      .UsedRange.Offset(1).ClearContents
      .Range("A2").Resize(rws - 1, 3).Value = Application.Index(aResults, aRws, Array(j, j + 1, j + 2))
    End With
  Next j
End Sub

Yes, the current code keeps going when no more key words are found for 4 rows, and copies said information regardless of data in them. I do not want it to do this.

The reason that was happening relates to all the lines in the code similar to the one below. I don't know why elmer007 had those red 5s in there, but they should have been 1s instead.

However, if my code does what you want, it should be much faster acting on your approx 10,000 rows of data than elmer's code.

Sheets("TRANSF").Cells(wCount + 1, 1).Resize(5, 7).Value = myRange.Resize(5, 7).Value

 

[bvherrera]

My reading of point 4 in post #1 is that you also want a sheet called "NOT FOUND" and for it to include any rows from Sheet1 that includes data in column E that doesn't take it to one of the other 4 results sheets. If that is so, then try this in a copy of your workbook.

a) Make sure that as well as 'Sheet1' with the original data, you have sheets named 'TRANSF", 'SURPLUS', 'LOST', 'NO CMDB' and 'NOT FOUND'.
b) On each of the 5 results sheets, enter the required headings in columns A:C. If these are to just be the headings from columns E:G of Sheet1, then post back and the code could be modified to do that for you.
c) Run the following code. (Make sure that you include the 'Option Compare Text' line at the top of the module.

I made a copy of my data in a new worksheet, all 6 sheets named correctly, however it gives an error of "Subscript out of range", then directs me to the following line when debugged:

aResults(1, k) = aResults(1, k) + 1

 

[Peter_SSs]

I made a copy of my data in a new worksheet, all 6 sheets named correctly, however it gives an error of "Subscript out of range", then directs me to the following line when debugged:

aResults(1, k) = aResults(1, k) + 1

That would indicate most likely that cell E2 is empty. In any case, the code needs a slight tweak. Add in these blue lines where shown and try again.

      Case aData(i, 1) <> vbNullString: k = 14
      Case Else: k = 0
    End Select
    If k > 0 Then
      aResults(1, k) = aResults(1, k) + 1
      For j = 1 To 3
        aResults(aResults(1, k), k + j - 2) = aData(i, j)
      Next j
    End If
  Next i

 

[bvherrera]

That would indicate most likely that cell E2 is empty. In any case, the code needs a slight tweak. Add in these blue lines where shown and try again.

      Case aData(i, 1) <> vbNullString: k = 14
      Case Else: k = 0
    End Select
    If k > 0 Then
      aResults(1, k) = aResults(1, k) + 1
      For j = 1 To 3
        aResults(aResults(1, k), k + j - 2) = aData(i, j)
      Next j
    End If
  Next i

This worked beautifully. Thank you so much!

For my own edification, how would I go about adding an additional keyword to search for and break off into another sheet in this code? With the one elmer007 made, it was pretty straight-forward on adding additional criteria.

I see that in the following line, it specifies the sheet names, so I would have to put in another, but why the additional (")s?

aShts = Split("TRANSF,1,,SURPLUS,1,,LOST,1,,NO CMDB,1,,NOT FOUND,1,"[COLOR=#ff0000], ","[/COLOR])

Then I would create a case for it, being in these lines, but what does the variable k do?

    Select Case True
      Case InStr(1, aData(i, 1), "transf"): [COLOR=#ff0000]k = 2[/COLOR]
      Case InStr(1, aData(i, 1), "surplus"): [COLOR=#ff0000]k = 5[/COLOR]
      Case InStr(1, aData(i, 1), "lost"): [COLOR=#ff0000]k = 8[/COLOR]
      Case InStr(1, aData(i, 1), "no cmdb"): [COLOR=#ff0000]k = 11[/COLOR]
      Case aData(i, 1) <> vbNullString: [COLOR=#ff0000]k = 14[/COLOR]

Again, thank you for the help!