D
Dakota
I have a worksheet called 'Exceptions' with data that I need to have applied
to multiple worksheets within the workbook based upon the value in A1
matching the value of B6 on the individual worksheets. This matching works,
but I need to have only the B column value on the 'Exceptions' sheet added to
each worksheet. The code below is copying the entire row of data (6 columns)
from the 'Exceptions' worksheet where the A1 value matches the B6 value on
the worksheets (which is what i initially wanted but now I need to strip
everything and only copy the one cell).
Can someone show me where I can make this change? Every time I do it, I get
different data sets added to my worksheets.
Sub Exceptions()
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long
With Worksheets("Exceptions")
Set r = .Range(.Range("A1"), .Range("A1").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "exceptions" Then
If sh.Cells(6, "B").Value = cell Then
If Application.CountIf(sh.Columns(1), cell) > 0 Then
lastrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
cell.Resize(1, 6).Copy
sh.Cells(lastrow + 1, 1).PasteSpecial xlPasteValues
Else
cell.Resize(1, 6).Copy
sh.Range("A50").PasteSpecial xlPasteValues
End If
Exit For
End If
End If
Next
Next
End Sub
to multiple worksheets within the workbook based upon the value in A1
matching the value of B6 on the individual worksheets. This matching works,
but I need to have only the B column value on the 'Exceptions' sheet added to
each worksheet. The code below is copying the entire row of data (6 columns)
from the 'Exceptions' worksheet where the A1 value matches the B6 value on
the worksheets (which is what i initially wanted but now I need to strip
everything and only copy the one cell).
Can someone show me where I can make this change? Every time I do it, I get
different data sets added to my worksheets.
Sub Exceptions()
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long
With Worksheets("Exceptions")
Set r = .Range(.Range("A1"), .Range("A1").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "exceptions" Then
If sh.Cells(6, "B").Value = cell Then
If Application.CountIf(sh.Columns(1), cell) > 0 Then
lastrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
cell.Resize(1, 6).Copy
sh.Cells(lastrow + 1, 1).PasteSpecial xlPasteValues
Else
cell.Resize(1, 6).Copy
sh.Range("A50").PasteSpecial xlPasteValues
End If
Exit For
End If
End If
Next
Next
End Sub