Maro Required - Fill in texts in cells based on other cell values

[Blaster1]

Hi Guys,

I am new here and want a MACRO help.
I want to use a MACRO code to be applied to ALL Worksheets within one workbook.

If cells A2 (as an example) containts text (any text) then fill in B2 with "John Smith" C2 with date "12 09 21" and D2 with "John Smith" but with special font (MISTRAL Font).
I want this to be applied for all rows associated with column range A2:A11 (when there is not text in a any cell of range A2:A11 like A6 in below image, then do nothing) then applies it to all worksheets in the workbook.
Thanks.

 

[Peter_SSs]

Which column?

Assuming it is column B (easy to edit to another column) you could try this. I am doing the row deletion first as it seems pointless filling in all the other values if you might be deleting those rows later anyway.
Try this with a copy of your workbook.

I was slightly unclear if the row containing one of those texts should be included in the deletion or only all the rows below. My code does delete the row containing the text as well. Post back if you need the modification to leave the first 'text' row.

Sub FillValues_v2()
  Dim ws As Worksheet
  Dim a(1 To 3) As Variant
  Dim DelRow1 As Long
  
  a(1) = "John Smith":  a(2) = DateSerial(2021, 12, 9): a(3) = a(1)
  For Each ws In Worksheets
    With ws.Range("B4:B" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      DelRow1 = 0
      .AutoFilter Field:=1, Criteria1:=Array("Text1", "Text2", "Text3"), Operator:=xlFilterValues
      If .SpecialCells(xlVisible).Count > 1 Then DelRow1 = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Areas(1).Cells(1).Row
      ws.AutoFilterMode = False
      If DelRow1 > 0 Then ws.Rows(DelRow1).Resize(.Row + .Rows.Count - 1).Delete
    End With
    With ws.Range("E5:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .Value = a
      On Error Resume Next
      Intersect(.Columns(0).SpecialCells(xlBlanks).EntireRow, .EntireColumn).ClearContents
      On Error GoTo 0
      .Columns(2).NumberFormat = "dd mm yy"
      .Columns(3).Font.Name = "Mistral"
      With .Offset(, -4).Resize(, 8)
        On Error Resume Next
        .SpecialCells(xlBlanks).Value = "text"
        On Error GoTo 0
        .EntireColumn.AutoFit
      End With
    End With
  Next ws
End Sub

 

[Blaster1]

see below image.
Delete ALL rows that have in Column B "ABC" or "KLM" or "XYZ" or "ZYX".
in below case, rows 15 to 24 to be deleted.

 

[Blaster1]

Assuming it is column B (easy to edit to another column) you could try this. I am doing the row deletion first as it seems pointless filling in all the other values if you might be deleting those rows later anyway.
Try this with a copy of your workbook.

I was slightly unclear if the row containing one of those texts should be included in the deletion or only all the rows below. My code does delete the row containing the text as well. Post back if you need the modification to leave the first 'text' row.

Sub FillValues_v2()
  Dim ws As Worksheet
  Dim a(1 To 3) As Variant
  Dim DelRow1 As Long
 
  a(1) = "John Smith":  a(2) = DateSerial(2021, 12, 9): a(3) = a(1)
  For Each ws In Worksheets
    With ws.Range("B4:B" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      DelRow1 = 0
      .AutoFilter Field:=1, Criteria1:=Array("Text1", "Text2", "Text3"), Operator:=xlFilterValues
      If .SpecialCells(xlVisible).Count > 1 Then DelRow1 = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Areas(1).Cells(1).Row
      ws.AutoFilterMode = False
      If DelRow1 > 0 Then ws.Rows(DelRow1).Resize(.Row + .Rows.Count - 1).Delete
    End With
    With ws.Range("E5:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .Value = a
      On Error Resume Next
      Intersect(.Columns(0).SpecialCells(xlBlanks).EntireRow, .EntireColumn).ClearContents
      On Error GoTo 0
      .Columns(2).NumberFormat = "dd mm yy"
      .Columns(3).Font.Name = "Mistral"
      With .Offset(, -4).Resize(, 8)
        On Error Resume Next
        .SpecialCells(xlBlanks).Value = "text"
        On Error GoTo 0
        .EntireColumn.AutoFit
      End With
    End With
  Next ws
End Sub

This didn't work properly with me ...
can you embed: Delete ALL rows that have in Column B "Text1" or "Text2" or "Text3" or "Text4".
in below code you sent earlier?
thanks.


Sub Test()
Dim Lr As Long, Sh As Worksheet, i As Long, Ar() As Variant
For Each Sh In Worksheets
With Sh
Lr = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("F2:F" & Lr).NumberFormat = "mm dd yyyy"
.Range("G2:G" & Lr).Font.Name = "Mistral"
For i = 2 To Lr
If .Range("D" & i).Value <> "" Then
.Range("E" & i).Value = "John Smith"
.Range("F" & i).Value = CDate(44539)
.Range("G" & i).Value = "John Smith"
End If
Columns("A:H").AutoFit
Next i
.Range("A5:H" & Lr).SpecialCells(xlCellTypeBlanks).Value = "Text"
End With
Next Sh
End Sub

 

[Peter_SSs]

This didn't work properly with me ...
can you embed: Delete ALL rows that have in Column B "Text1" or "Text2" or "Text3" or "Text4".
in below code you sent earlier?

I did not send the "below code you posted earlier".
It is not surprising that my latest code did not work for you because you have changed the specification (compare bold & underlined texts)

if a cell contains "Text1" or "Text2" or "Text3" the select this row and delete ALL rows underneath ...

I can't look at it right now but will re-visit it a bit later.

BTW, when posting code in the forum please use the available code tags so the code is formatted. My signature block below has more details.

I also suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with. We can't do anything with a picture apart from look at it.

 

[maabadi]

This code is Mine Not Peter. Are you Test Peter Codes? I think It is very Better Than My code.
But if you want work with my code Try this:

Sub Test()
Dim Lr As Long, Sh As Worksheet, i As Long, Ar() As Variant
For Each Sh In Worksheets
With Sh
Lr = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("F2:F" & Lr).NumberFormat = "mm dd yyyy"
.Range("G2:G" & Lr).Font.Name = "Mistral"
For i = Lr To 2 Step -1
if .Range("B" & i).Value = "ABC" or .Range("B" & i).Value = "KLM" or .Range("B" & i).Value = "XYZ" or .Range("B" & i).Value = "ZYX" Then
Rows(i).Delete
Else
If .Range("D" & i).Value <> "" Then
.Range("E" & i).Value = "John Smith"
.Range("F" & i).Value = CDate(44539)
.Range("G" & i).Value = "John Smith"
End If
End if
Next i
.Range("A5:H" & Lr).SpecialCells(xlCellTypeBlanks).Value = "Text"
Columns("A:H").AutoFit
End With
Next Sh
End Sub

 

[Peter_SSs]

So here is my revised code based on my current understanding.

Sub FillValues_v3()
  Dim ws As Worksheet
  Dim a(1 To 3) As Variant

  a(1) = "John Smith":  a(2) = DateSerial(2021, 12, 9): a(3) = a(1)
  For Each ws In Worksheets
    With ws.Range("B4:B" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter Field:=1, Criteria1:=Array("ABC", "KLM", "XYZ", "ZYX"), Operator:=xlFilterValues
     .Offset(1).EntireRow.Delete
      ws.AutoFilterMode = False
    End With
    With ws.Range("E5:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .Value = a
      On Error Resume Next
      Intersect(.Columns(0).SpecialCells(xlBlanks).EntireRow, .EntireColumn).ClearContents
      On Error GoTo 0
      .Columns(2).NumberFormat = "dd mm yy"
      .Columns(3).Font.Name = "Mistral"
      With .Offset(, -4).Resize(, 8)
        On Error Resume Next
        .SpecialCells(xlBlanks).Value = "text"
        On Error GoTo 0
        .EntireColumn.AutoFit
      End With
    End With
  Next ws
End Sub

 

[Blaster1]

So here is my revised code based on my current understanding.

Sub FillValues_v3()
  Dim ws As Worksheet
  Dim a(1 To 3) As Variant

  a(1) = "John Smith":  a(2) = DateSerial(2021, 12, 9): a(3) = a(1)
  For Each ws In Worksheets
    With ws.Range("B4:B" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter Field:=1, Criteria1:=Array("ABC", "KLM", "XYZ", "ZYX"), Operator:=xlFilterValues
     .Offset(1).EntireRow.Delete
      ws.AutoFilterMode = False
    End With
    With ws.Range("E5:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)
      .Value = a
      On Error Resume Next
      Intersect(.Columns(0).SpecialCells(xlBlanks).EntireRow, .EntireColumn).ClearContents
      On Error GoTo 0
      .Columns(2).NumberFormat = "dd mm yy"
      .Columns(3).Font.Name = "Mistral"
      With .Offset(, -4).Resize(, 8)
        On Error Resume Next
        .SpecialCells(xlBlanks).Value = "text"
        On Error GoTo 0
        .EntireColumn.AutoFit
      End With
    End With
  Next ws
End Sub

That Perfectly Worked!!
Thank you very much and apologies for the code tags as I am still new here. I will have a look at your signature for more details.

 

[Blaster1]

This code is Mine Not Peter. Are you Test Peter Codes? I think It is very Better Than My code.
But if you want work with my code Try this:

Sub Test()
Dim Lr As Long, Sh As Worksheet, i As Long, Ar() As Variant
For Each Sh In Worksheets
With Sh
Lr = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("F2:F" & Lr).NumberFormat = "mm dd yyyy"
.Range("G2:G" & Lr).Font.Name = "Mistral"
For i = Lr To 2 Step -1
if .Range("B" & i).Value = "ABC" or .Range("B" & i).Value = "KLM" or .Range("B" & i).Value = "XYZ" or .Range("B" & i).Value = "ZYX" Then
Rows(i).Delete
Else
If .Range("D" & i).Value <> "" Then
.Range("E" & i).Value = "John Smith"
.Range("F" & i).Value = CDate(44539)
.Range("G" & i).Value = "John Smith"
End If
End if
Next i
.Range("A5:H" & Lr).SpecialCells(xlCellTypeBlanks).Value = "Text"
Columns("A:H").AutoFit
End With
Next Sh
End Sub

Thanks mate, appreciate all the help.

 

[maabadi]

You're Welcome & Thanks for follow-up.

 

[Peter_SSs]

That Perfectly Worked!!

You're welcome. Thanks for the follow-up.