VBA for formatting cells to be same as other cells

[JIMMY024]

Hi
looking for some help with formatting cells.

I currently have a spreadsheet that automatically populates depending on a value that is in a certain cell (target address).
The information (target range) is pulled from another sheet ( Sheet 25) and then dropped into the named area I need ("B13:B105")
What I would like is when data comes across into the destination cells ( ("B13:B105") it is in the same font and format as the original i.e. that format in sheet 25 Range.
Currently the info on sheet 25 has all sorts of bold and highlighting which is not being carried across.
also if it could auto size the cells ("B13:B105") to fit the data from the range , and delete any empty rows that would be a bonus..

Here is the code I have so far. any help would be appreciated.

Sub Worksheet_Change(ByVal Target As Range)
' Predetermined values are populated in cells B13:B105 based on type of Agreement.
Application.ScreenUpdating = False

If Target.Address = "$G$11" Then
If Target = "Construction" Then
Range("B13:B105") = Sheet25.Range("A56:A148").Value
ElseIf Target = "Works" Then
Range("B13:B105") = Sheet25.Range("B56:B148").Value
ElseIf Target = "Minor Works" Then
Range("B13:B105") = Sheet25.Range("C56:C148").Value

End If
End If

Application.ScreenUpdating = False

End Sub

Any help would be appreciated.
Thanks
Jim

 

[tonyyy]

To delete blank cells/rows, add the line in red...

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("G11")) Is Nothing Then
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    ' Predetermined values are populated in cells B13:B105 based on type of Agreement.
    If Target.Address = "$G$11" Then
        If Target = "Construction" Then Sheets("Sheet25").Range("A56:A148").Copy Destination:=Range("B13:B105")
        If Target = "Works" Then Sheets("Sheet25").Range("B56:B148").Copy Destination:=Range("B13:B105")
        If Target = "Minor Works" Then Sheets("Sheet25").Range("C56:C148").Copy Destination:=Range("B13:B105")
    End If
    [COLOR=#ff0000]Range("B13:B105").SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/COLOR]
    Columns(2).AutoFit
End If
Application.ScreenUpdating = True
End Sub

Cheers,

tonyyy

 

[My Aswer Is This]

Thanks for that answer Tony.
Ok now the script needs to look like this due to the fact this is a sheet change event

Sub Worksheet_Change(ByVal Target As Range)
 ' Predetermined values are populated in cells B13:B105 based on type of Agreement.
 On Error GoTo M

 Application.ScreenUpdating = False
If Not Intersect(Target, Range("G11")) Is Nothing Then

 If Target.Address = "$G$11" Then
 If Target = "Construction" Then Sheet25.Range("A56:A148").Copy Destination:=Range("B13:B105")
 If Target = "Works" Then Sheet25.Range("B56:B148").Copy Destination:=Range("B13:B105")
 If Target = "Minor Works" Then Sheet25.Range("C56:C148").Copy Destination:=Range("B13:B105")
 End If
 Columns(2).AutoFit
 Application.EnableEvents = False
 Range("B13:B105").SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)

Application.EnableEvents = True
Exit Sub
M: MsgBox "A Error Occured"
Application.EnableEvents = True
Application.ScreenUpdating = False
End If
 End Sub

 

[tonyyy]

And to address merged cells...

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, Range("G11")) Is Nothing Then
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    ' Predetermined values are populated in cells B13:B105 based on type of Agreement.
    If Target.Address = "$G$11" Then
        [COLOR=#ff0000]Range("B13:B105").UnMerge[/COLOR]
        If Target = "Construction" Then Sheets("Sheet25").Range("A56:A148").Copy Destination:=Range("B13:B105")
        If Target = "Works" Then Sheets("Sheet25").Range("B56:B148").Copy Destination:=Range("B13:B105")
        If Target = "Minor Works" Then Sheets("Sheet25").Range("C56:C148").Copy Destination:=Range("B13:B105")
    End If
    Range("B13:B105").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns(2).AutoFit
End If
Application.ScreenUpdating = True
End Sub

This is a simplistic approach, and if you plan to continue to run macros against this range it's strongly suggested not to use merged cells.

In its place, you could use the Alignment format...
Select the cells you want to "merge", eg, Range("B13:C13")
Right click the cells and choose Format Cells...
In the Alignment tab, in the Horizontal selection, choose Center Across Selection.
It'll have the same visual effect as merged cells without the headaches.

Not to say you couldn't use vba to detect all merged cells, unmerge them while you copy/paste, then reset the merged cells... but good luck finding someone willing to code that.

Cheers,

tonyyy

 

[My Aswer Is This]

Thanks Tony for your help. I forget some of these little lines of code from time to time.

 

[tonyyy]

Happy to help, MAIT! We all need a little help from time to time...

 

[JIMMY024]

THank you both..
Im learning that mergeing cells is not a good thing.

I don't have that many tabs that have berged destination cells so im going to just manually fix those tabs so the code will be same for all.

I think going forward ill be sure to make sure merging is used just for sake of it.

Thanks to you both again.
Jim

 

[My Aswer Is This]

So we are good here? Your script is now doing all you want?

THank you both..
Im learning that mergeing cells is not a good thing.

I don't have that many tabs that have berged destination cells so im going to just manually fix those tabs so the code will be same for all.

I think going forward ill be sure to make sure merging is used just for sake of it.

Thanks to you both again.
Jim

 

[JIMMY024]

Hi My Aswer
Sorry for the delay...its partly because I was busy unmerging cells and missed the notification
But also wanted to make sure everything was good.

All is working well. Thank you again.
Cheers
Jim

 

[My Aswer Is This]

Glad I was able to help you. Come back here to Mr. Excel next time you need additional assistance.

Hi My Aswer
Sorry for the delay...its partly because I was busy unmerging cells and missed the notification
But also wanted to make sure everything was good.

All is working well. Thank you again.
Cheers
Jim