Extract all words from one table written with all caps and put in other excel sheet

[Vallenato]

Hello!
I have a sheet containing rows with data. In the B column of each row there is a word written, sometimes with small caps, sometimes with all caps and sometimes with both. I would like excel to automatically (without button) show the B and D column of rows containing only all caps words in the B column (if there are numbers combined with the all caps that's OK too) in another worksheet (in column A and C in sheet2, showing the B column names from Sheet1 starting with a cap and then the rest of the word with small caps) and keep it always updated in case I make changes in sheet 1. Is there a way to do this with vba?

An example of sheet1:

car Rob 44 87
bike Jon1 37 98
plane MIKE 87 79
dog Ron 77 98
cat JAY1 65 12


and sheet2 will show:

Mike 79
Jay1 12

 

[Rick Rothstein]

Give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub ExtractAllCaps()
  Dim R As Long, X As Long, Data As Variant, Result As Variant
  Data = Sheets("Sheet1").Range("B1", Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp))
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Not Data(R, 1) Like "*[!A-Z0-9]*" Then
      X = X + 1
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Data(R, 3)
    End If
  Next
  Sheets("Sheet2").Range("A1").Resize(UBound(Result), 2) = Result
End Sub[/td]
[/tr]
[/table]

 

[Vallenato]

Hello Rick!
It works! Thank you!!! Two questions:

1. Is it possible to make the code work as well if there is a blank row in between rows with data and sheet 2 doesn´t get this blank row (i.e. JAY1 in the example below gets copied directly under MIKE without the blank row in sheet2)?

For example if sheet1 would look like this:

car Rob 44 87
bike Jon1 37 98
plane MIKE 87 79
dog Ron 77 98

cat JAY1 65 12


Sheet2 will still show:

Mike 79
Jay1 12

2. And finally, to get the all caps in column A in sheet2 to change so that it says Mike and not MIKE in this target sheet?

 

[Rick Rothstein]

This should do it for you...

[table="width: 500"]
[tr]
	[td]Sub ExtractAllCaps()
  Dim R As Long, X As Long, Data As Variant, Result As Variant
  Data = Sheets("Sheet1").Range("B1", Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp))
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Not Data(R, 1) Like "*[!A-Z0-9]*" And Len(Data(R, 1)) > 0 Then
      X = X + 1
      Result(X, 1) = Application.Proper(Data(R, 1))
      Result(X, 2) = Data(R, 3)
    End If
  Next
  Sheets("Sheet2").Range("A1").Resize(UBound(Result), 2) = Result
End Sub[/td]
[/tr]
[/table]

 

[Vallenato]

Hello Rick!
Thanks again for your kindness taking time to help me with this vba-issue. Now the macro works quite fine! But after testing it I found two things that isn´t really working as I thought it would.

First, if I don´t write anything in column D it will not copy column B to Sheet2. There may be rows were column D will have a blank value in Sheet1 and then I still want column B to be copied from Sheet1 to Sheet2.

Second, if I delete rows in Sheet1 it will not delete the corresponding rows in Sheet2 (it only seems to be working with the first row?!).

Could you add something to the code to get these two details to work better? Thank you again for your effort!!!

 

[Vallenato]

Hello Rick!
Thanks again for your kindness taking time to help me with this vba-issue. Now the macro works quite fine! But after testing it I found two things that isn´t really working as I thought it would.

First, if I don´t write anything in column D it will not copy column B to Sheet2. There may be rows were column D will have a blank value in Sheet1 and then I still want column B to be copied from Sheet1 to Sheet2.

Second, if I delete rows in Sheet1 it will not delete the corresponding rows in Sheet2 (it only seems to be working with the first row?!).

Could you add something to the code to get these two details to work better? Thank you again for your effort!!!

 

[Rick Rothstein]

Hello Rick!
Thanks again for your kindness taking time to help me with this vba-issue. Now the macro works quite fine! But after testing it I found two things that isn´t really working as I thought it would.

First, if I don´t write anything in column D it will not copy column B to Sheet2. There may be rows were column D will have a blank value in Sheet1 and then I still want column B to be copied from Sheet1 to Sheet2.

Second, if I delete rows in Sheet1 it will not delete the corresponding rows in Sheet2 (it only seems to be working with the first row?!).

Could you add something to the code to get these two details to work better? Thank you again for your effort!!!

See if this modified code works the way you want...

Sub ExtractAllCaps()
  Dim R As Long, X As Long, Data As Variant, Result As Variant
  Data = Sheets("Sheet1").Range("B1", Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(, 2))
  ReDim Result(1 To UBound(Data), 1 To 2)
  For R = 1 To UBound(Data)
    If Not Data(R, 1) Like "*[!A-Z0-9]*" Then
      X = X + 1
      Result(X, 1) = Data(R, 1)
      Result(X, 2) = Data(R, 3)
    End If
  Next
  Sheets("Sheet2").UsedRange.Clear
  Sheets("Sheet2").Range("A1").Resize(UBound(Result), 2) = Result
End Sub

 

[Vallenato]

Thanks Rick Rothstein! Now it works great! Thanks again!