Add data from one sheet to another if value is met

[HansV]

The code will check for each of the cells that you specify whether it has changed.

Note: You should try to indent code consistently: the End If should start at the same position from the left margin as the If it belongs to; code between If and End If should be indented one tab stop further. See the code that I posted.

[ABabeNChrist]

Thank You HansV
Yeah I agree I need to work on that
It does make it easier to read and understand when its layout correctly

[ABabeNChrist]

Hi HansV
This code works great, but one small problem I discovered is since I use this code for a variety of different sheets and when the value is met at each location of each sheet it is then placed on the summary page. At the present moment I have to leave a curtain amount of rows available for each sheet, just in case all values are met for that sheet.
Below is how my summary page may appear when only a few values are met for sheet/area.
Each name like Grounds, Roof, Bedroom and bathroom represents a different sheet.
I was wonder if I should hide the rows and when value is met it would then unhide that row and then insert comment. Is this possible or is there a better method.

sum.JPG

[HansV]

I'd delete the rows between the "headers" except for two between each pair.
Use code to insert rows and populate them as needed.

[ABabeNChrist]

Hi HansV
I was able to insert rows, and it seems to work OK up to this point, but if I were to retract my comment for whatever reason, the inserted row will still be there. I tried adding some other code with Else that would delete a row, but that’s a bad idea also. How do I get around this?
I also added some code that would AutoFitMergedCellRowHeight if the text was too large for cell. But of course this doesn’t seem to work as I was hoping. It seems that I would have to tab out of cell for it to take effect.
Here the code so far
Also I'm trying to learn to line up my code as you suggested

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("A4"), Target) Is Nothing Then
    Application.EnableEvents = False
    Select Case Range("A4").Value
      Case "Bad", "Ugly"
        Sheet2.Range("A2").EntireRow.Insert
        Sheet2.Range("A2").Value = Range("A6").Value
      Case Else
        Sheet2.Range("A2").EntireRow.Delete
        Sheet2.Range("A2").Value = ""
    End Select
    Application.EnableEvents = True
  End If
    If Not Intersect(Range("A10"), Target) Is Nothing Then
    Application.EnableEvents = False
    Select Case Range("A10").Value
      Case "Bad", "Ugly"
        Sheet2.Range("A3").EntireRow.Insert
        Sheet2.Range("A3").Value = Range("A12").Value
      Case Else
        Sheet2.Range("A3").EntireRow.Delete
        Sheet2.Range("A3").Value = ""
    End Select
    Application.EnableEvents = True
  End If
    If Not Intersect(Target, Range("A6,A12")) Is Nothing Then
        Target.Select
        AutoFitMergedCellRowHeight
    End If

  End Sub

[ABabeNChrist]

Hi HansV
I could seem to get the insert row to work correctly
I did how ever played around with hiding the rows using

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("A4"), Target) Is Nothing Then
    Application.EnableEvents = False
    Select Case Range("A4").Value
      Case "Bad", "Ugly"
        Sheet2.Rows("2").EntireRow.Hidden = False
        Sheet2.Range("A2").Value = Range("A6").Value
      Case Else
        Sheet2.Rows("2").EntireRow.Hidden = True
        Sheet2.Range("A2").Value = ""
    End Select
    Application.EnableEvents = True
  End If
    If Not Intersect(Range("A10"), Target) Is Nothing Then
    Application.EnableEvents = False
    Select Case Range("A10").Value
      Case "Bad", "Ugly"
        Sheet2.Rows("3").EntireRow.Hidden = False
        Sheet2.Range("A3").Value = Range("A12").Value
      Case Else
        Sheet2.Rows("3").EntireRow.Hidden = True
        Sheet2.Range("A3").Value = ""
    End Select
    Application.EnableEvents = True
  End If
    If Not Intersect(Target, Range("A6,A12")) Is Nothing Then
        Target.Select
        AutoFitMergedCellRowHeight
    End If

  End Sub

It seems to work good, is there a reason you prefered inserting a row over hiding a row.

[HansV]

If hiding and unhiding works OK for you, I'd go with it.
But keep in mind that the hidden rows will still be there, so if there's something in those rows that you don't want the user to see, you could have a problem.

[ABabeNChrist]

Hi HansV
I like the way the hide and hide method works, it serves its purpose, plus there’s no information in those cells anyway.
As you may have noticed I added this to the code because of Worksheet_Change

Code: Select all

    If Not Intersect(Target, Range("A7")) Is Nothing Then
        Target.Select
        AutoFitMergedCellRowHeight
    End If
End Sub

I also have this same code in place on the target “Summary” but will not run, even though the source “Sheet1” is , is there something I can change that will run this code, should I apply with the existing after

Code: Select all

Sheets("Summary").Range("F6").Value = Range("H20").Value

From Sheet1

[HansV]

I don't know what AutoFitMergedCellRowHeight is - is it a macro? It's not a built-in feature.

[ABabeNChrist]

Yes it is a macro , it works quite well

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Use the Range to select desired cells
    If Not Intersect(Target, Range("A7")) Is Nothing Then
        Target.Select
        AutoFitMergedCellRowHeight
    End If
End Sub

[HansV]

That is more or less the same code you had already posted.

What is the code of AutoFitMergedCellRowHeight?

[ABabeNChrist]

That is more or less the same code you had already posted.

What is the code of AutoFitMergedCellRowHeight?

Here is the other portion that goes inside a module

Code: Select all

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = PossNewRowHeight
End If
End With
End If
End Sub

It works the same as AutoRowHeight but with merged cells. Once data has gone beyond the size of the cell that it’s in, it will auto heighten the size of cell / row to accommodate.

[HansV]

1. It would be best to avoid using merged cells.
2. You should try to indent your code consistently (I've mentioned this before). Properly indented code is much easier to read and understand.
3. If you absolutely MUST use merged cells, replace the code for AutoFitMergedCellRowHeight with the following:

Code: Select all

Sub AutoFitMergedCellRowHeight()
  AFMCRH Selection
End Sub

Sub AFMCRH(rng As Range)
  Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
  Dim CurrCell As Range
  Dim ActiveCellWidth As Single, PossNewRowHeight As Single
  If rng.MergeCells Then
    With rng.MergeArea
      If .Rows.Count = 1 And .WrapText = True Then
        Application.ScreenUpdating = False
        CurrentRowHeight = .RowHeight
        ActiveCellWidth = .Cells(1).ColumnWidth
        For Each CurrCell In Selection
          MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
        Next CurrCell
        .MergeCells = False
        .Cells(1).ColumnWidth = MergedCellRgWidth
        .EntireRow.AutoFit
        PossNewRowHeight = .RowHeight
        .Cells(1).ColumnWidth = ActiveCellWidth
        .MergeCells = True
        .RowHeight = PossNewRowHeight
      End If
    End With
  End If
End Sub

Change the Worksheet_Change code to

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  If Not Intersect(Target, Range("A7")) Is Nothing Then
    AFMCRH Range("A7")
  End If
End Sub

[ABabeNChrist]

Thank you HansV
Once More, you are always so very helpful
I 100% agree with you about indenting my code, I have been trying this practice, but in my defense this last code was a copy and paste.
Also I do have to confess I like the way I can manipulate a sheet using merged cells. I’ve heard some horror stories; I believe there is a way around just about anything. If you where to see one of my workbooks its nothing but merged cells, it took a lot of tweaking and twisting to get it to work the way I attended. And for the most part it operates better than I hoped for.

[VegasNath]

Thank you HansV
If you where to see one of my workbooks its nothing but merged cells, it took a lot of tweaking and twisting to get it to work the way I attended.

In my early days of working in Excel, I used merged cells a lot. One thing that I have learned since meeting VBA is to avoid them like the plague! Now I rarely ever use them.