Problem Pasting a Range of data into a Worksheet_Change

D

drhill78

New Member
Joined
Feb 21, 2019
Messages
12
I'm pretty amateur when it comes to VBA, but not to code wrangling on the whole, but this issue has me beating my head against a wall.

I have a page set up to use Worksheet_Change(ByVal Target As Range) in order to propagate additional cells in the row with different formulae to provide information about a part number entered into column A.

Worksheet_Change(ByVal Target As Range) is something new I'm adding to previously existing code to make it look fancier and bury the formulae in the VBA instead of the cells themselves (like I did in my previous version).

(Aside: The formulae aren't the problem and I don't have unique ones plugged in for all the fields yet, I'm trying to get the Sort Button working first)

I have a button set up on the Page that is supposed to combine like Part Numbers (from Column A) and sum the totals of them (from column B) and then sort them alphabetically and spit them back out into two different places.

This button worked perfectly on my last version, but now I'm having a hang-up using it in conjunction with Worksheet_Change(ByVal Target As Range).

Any assistance would be appreciated. I'm not looking to make "pretty code" yet. I'm just trying to understand what I'm doing/doing wrong as I try to implement my goals.

I have a few ideas as to what is hanging up and why, but it'll save me some time and headache if someone can help me out.

I believe the following should be all the relevant code you should need:

VBA Code: 
'Option Explicit requires me to define my variables
Option Explicit
'Define the variables globally
Dim LR As Long, TR As Long, LR2 As Long, LR3 As Long, i As Long, j As Long
Dim ws1 As Worksheet, ws As Worksheet, ws2 As Worksheet
Dim ws1Name As String, ws2Name As String
Dim Target As Range
Dim myFormula As String

Private Sub Worksheet_Change(ByVal Target As Range)
    LR = Me.Cells(Rows.Count, 1).End(xlUp).Row
    TR = Target.Row
    Application.EnableEvents = False
    Application.ScreenUpdating = False
       If Not Intersect(Target, Range("A5:A" & LR + 1)) Is Nothing Then
            With Range("A5:Q5000")
                With .Borders(xlInsideHorizontal)
                    .LineStyle = xlNone
                End With
                 With .Borders(xlInsideVertical)
                    .LineStyle = xlNone
                End With
                .BorderAround LineStyle:=xlNone
            End With
            LR = Me.Cells(Rows.Count, 1).End(xlUp).Row
            With Range("A5:P" & LR + 1)
                With .Borders(xlInsideHorizontal)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlColorIndexAutomatic
                    .Weight = xlThin
                End With
                 With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlColorIndexAutomatic
                    .Weight = xlThin
                End With
                .BorderAround LineStyle:=xlContinuous, Weight:=xlThick, ColorIndex:=xlColorIndexAutomatic
            End With
            If Target.Value <> "" Then    '<---------------------PROBLEM Line according to the Debugger, see Comment Block about my issue further down in the code
                Worksheets("Entry Page").Range("C" & TR).Formula = "=IFERROR(IF(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A" & TR & ",INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0))=A" & TR & ",OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A" & TR & ",INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,1)),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("D" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A" & TR & ",INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,30)=""N"",""NO SDS"",""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("E" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A" & TR & ",INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,30)=""N"",""NO SDS"",""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("F" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("G" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("H" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("I" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("J" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("K" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("L" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("M" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("N" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("O" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                Worksheets("Entry Page").Range("P" & TR).Formula = "=IFERROR(IF(OFFSET(INDEX(INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),MATCH(A5,INDIRECT(""Database!$B$2:$B$""&COUNTA(Database!$A$1:$A5000)),0)),0,33)="""",IF(H5=""N/A"",""N/A"",""NO SDS""),""YES SDS""),""NOT IN DATABASE"")"
                
                                
            Else
                Worksheets("Entry Page").Range("B" & TR & ":P" & TR).Value = ""
                  
            End If
        Else
        End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
        
End Sub


Private Sub CommandButton1_Click()
'Cycle through all sheets until sheet with desired CodeName is found
For Each ws In ThisWorkbook.Worksheets
        'Entry Page - permanently set as Sheet1
        If ws.CodeName = "Sheet1" Then
            ws1Name = ws.Name
        End If
        'ResultsPage
        If ws.CodeName = "Sheet6" Then
            ws2Name = ws.Name
        End If
    Next ws
'Turn off screen updating to stop screen flicker
Application.ScreenUpdating = False
'Select Worksheet
Worksheets(ws1Name).Select
Set ws1 = Worksheets(ws1Name)
    
With ws1
 
    'Find the last used row in column 1 = "A"
    LR = .Cells(Rows.Count, 1).End(xlUp).Row
 
    'Use AdvancedFilter on range A5:A LR
    '  of range A5:A LR
    'And, copy the unique values to T1
    .Range("A4:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T1"), Unique:=True
    'Find the last row of column T = 20
    LR2 = .Cells(Rows.Count, 20).End(xlUp).Row
    
    'I find it easier to use R1C1 reference for filling a range with a formula
    With .Range("U2:U" & LR2)
        'The next .FormulaR1C1 translates to:
        '             =SUMPRODUCT(--($A$5:$A$LR=$T2),$B$5:$B$LR)
        .FormulaR1C1 = "=SUMPRODUCT(--(R5C1:R" & LR & "C1=RC20),R5C2:R" & LR & "C2)"
        'Change the formula to its value
        .Value = .Value
        
        'Format the borders and font size
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlColorIndexAutomatic
        End With
        
        .Borders(xlEdgeRight).Weight = xlThick
        .Font.Size = 8
        
    End With
    'Clear original data - ws1.Range("A5:B LR")
    With ws1.Range("A5:B" & LR)
        .ClearContents
    End With

    'Sort and then Copy ws1.Range("T2:U LR2") to ws1.Range("A5")
    With ws1.Range("T2:U" & LR2)
        'Sort Alphabetically
        .Sort Key1:=Range("T2"), Order1:=xlAscending, Header:=xlNo
        'Copy Sorted Range over to original columns
        .Copy ws1.Range("A5") 
    End With
    
    'Comment Block about my issue:
    'It visually clears the original data fields, but throws an error before pasting anything into A5->
    'Additionally, the propagated cells which should be going blank when
    'the original data fields are cleared aren't getting cleared prior to the hangup
    'It's throwing a Run-time error '13': Type mismatch error
    'Is it because Target.Value needs to be a single cell and not several?
    'can I put some code in to cycle through the range of cells to be pasted one at a time and solve the problem? 
    '(I'm going to try that later today or tomorrow) Or is it something else?

    With ws1.Range("T1:U" & LR2)
      'Then clear ws1.Range("T1:U LR2")
      '
       .Clear
    End With
    
    'resize the page to original row height
    .Range("A1:A" & .Rows.Count).RowHeight = 11.25
End With

'send data to results worksheet
Worksheets(ws2Name).Select
Set ws2 = Worksheets(ws2Name)
With ws2
    'Find last row used in column B = 2
    LR3 = .Cells(Rows.Count, 2).End(xlUp).Row
    'clear destination locations
    With .Range("B3:C" & LR3)
        .ClearContents
    End With
End With
'copy data
With ws1.Range("A5:B" & LR)
    .Copy ws2.Range("B3")
End With
'Turn on screen updating, and exit/finish the macro
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
Just a thought...
Where is this code residing?
I don't believe you can just plonk it anywhere - there's a specific placeholder for it, in the "Worksheet" module; just check that's where you have it...
 
Upvote 0
... and if Target contains more than one cell, then you can loop through each cell, thus.
 
Upvote 0
I believe it is because Target range is not 1 cell. You can debug that line with Immediate or Watch windows to see it.

In immediate window when you get the error: ? target.cells.count
Or add a watch for: target.cells.count

You can do a for each...next to cycle all cells.

VBA Code: 
Dim cCell as Range

For Each cCell in Target
    ' Code Here
next cCell
 
Upvote 0
sykes said:
... and if Target contains more than one cell, then you can loop through each cell, thus.
Click to expand...
It's in the proper Worksheet module.

I didn't have time to futz with it yesterday after posting. I'm going to try to squeeze in some coding time a little later today. Thanks for the link to an example, though. I love examples. :)
 
Upvote 0
Ok, I got it all sorted. Thanks for the help. Kept me thinking in the right direction. I had to put in that For loop and just copy the cells over instead of copying the range over.

The section of code that I had to change to is this:

VBA Code: 
'Sort and then Copy ws1.Range("T2:U LR") to ws1.Range("A5")
    With ws1.Range("T2:U" & LR2)
        'Sort Alphabetically
        .Sort Key1:=Range("T2"), Order1:=xlAscending, Header:=xlNo
    End With
    'Copy Sorted Range over to original columns
    For i = 2 To LR2
        ws1.Cells(i, 20).Copy ws1.Cells(i + 3, 1)
        ws1.Cells(i, 21).Copy ws1.Cells(i + 3, 2)
    Next i
    
    With ws1.Range("T1:U" & LR2)
      'Then clear ws1.Range("T1:U LR2")
      '
       .Clear
    End With
 
Upvote 0
Solution
Instead of:

VBA Code: 
    For i = 2 To LR2
        ws1.Cells(i, 20).Copy ws1.Cells(i + 3, 1)
        ws1.Cells(i, 21).Copy ws1.Cells(i + 3, 2)
    Next i

These would also work. Just 2 examples, can be written differently of course.

VBA Code: 
ws1.Range(Cells(2,20),Cells(LR2,21)).Copy ws1.Range(5,1)

or

VBA Code: 
ws1.Cells(2,20).Resize(LR2-2+1,2).Copy ws1.Range(5,1)
' Intentionally kept -2+1 to show the calculation

Glad it got sorted though.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
Web search using Excel VBA error and script corrections
2
Replies
10
Views
181
Edgar_
Edgar_
I
  • Solved
Userform to worksheet values followed by 3 digits
Replies
2
Views
381
ipbr21054
I
S
  • Question Question
Error message when executing macro
Replies
3
Views
310
rlv01
R
S
  • Question Question
extracting data
Replies
1
Views
94
shamsu203
S
J
  • Solved
Userform sends to two worksheets - Positioning issues
2
Replies
13
Views
805
NoSparks
N

Forum statistics

Threads
1,223,907
Messages
6,175,301
Members
452,633
Latest member
DougMo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top