Copy Specific Range

[adam]

Hi anyone,

The following code copies the price range to the column “F” of the sheet “Receipt” when any amount from the price range is written in cells B5 & B6 from the sheet “Price Range.

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("B5:B6")) Is Nothing Then ' You can Change the range here

Item = Target.Offset(0, -1)

Set ItemNames = Sheets("Price Range").Range("A4:A11")

For Each c In ItemNames

If c = Item Then

PriceMin = c.Offset(0, 4)
PriceMax = c.Offset(0, 5)
If Target.Value <= PriceMax And Target.Value >= PriceMin Then

If Range("E2") = "Male" Then

PriceRange = c.Offset(0, 2).Value
Else
PriceRange = c.Offset(0, 3).Value
End If
Exit For
End If
End If
Next c
Target.Offset(0, 4) = PriceRange
End If

End Sub

I have added more columns to the worksheet Price Range, so that the price range specific for the "age" and "sex" is copied to the Receipt sheet from the sheet Price Range, when the age is written in the cell "B2"

Suppose If I write the age in cell "B2" as 56 Years, how could the code be adjusted so that the specific price range for that age and sex could be copied to the cell "F5" & "F6" in parallel with mango and orange.

Any help would be kindly appreciated.

Thanks in advance.

[HansV]

Could you attach a sample workbook? Thanks in advance.

[adam]

please find the attached sample

[HansV]

As I've told you many times before, you should do this in Microsoft Access.

Your age ranges are unusable. I've changed them all to years, and numbers for the minimum and maximum age in each range (formatted with a custom format), and made them consistent.

The code could look like this, which is COMPLETELY different from what you had:

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim oCell As Range
  Dim lngTargetRow As Long
  Dim lngSourceRow As Long
  Const lngMinRow = 4 ' First data row in Price Range sheet.
  Dim lngMaxRow As Long
  Dim strFruit As String
  Dim wshSource As Worksheet
  If Not Intersect(Target, Range("B2,E2")) Is Nothing Then ' You can Change the range here
    Application.EnableEvents = False
    ' Clear F5:F6
    Range("F5:F6").ClearContents
    If Range("B2") = "" Or Range("E2") = "" Then
      ' Can'lngTargetRow determine the price range - do nothing
    Else
      Set wshSource = Worksheets("Price Range")
      lngMaxRow = wshSource.Range("A" & wshSource.Rows.Count).End(xlUp).Row
      For lngTargetRow = 5 To 6
        strFruit = Range("A" & lngTargetRow)
        For lngSourceRow = lngMinRow To lngMaxRow
          If wshSource.Range("A" & lngSourceRow) = strFruit And _
              wshSource.Range("C" & lngSourceRow) <= Range("B2") And _
              wshSource.Range("D" & lngSourceRow) >= Range("B2") Then
            Select Case Range("E2")
              Case "Male"
                Range("F" & lngTargetRow) = wshSource.Range("E" & lngSourceRow)
              Case "Female"
                Range("F" & lngTargetRow) = wshSource.Range("H" & lngSourceRow)
            End Select
            Exit For
          End If
        Next lngSourceRow
      Next lngTargetRow
    End If
    Application.EnableEvents = True
  End If
End Sub

See the attached version.

CopySample02.xlsm

[adam]

Thanks for the code & Hans. I do really appreciate your help.

[adam]

I have modified your code as follows to suite my need

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim oCell As Range
  Dim lngTargetRow As Long
  Dim lngSourceRow As Long
  Const lngMinRow = 4 ' First data row in Price Range sheet.
  Dim lngMaxRow As Long
  Dim strFruit As String
  Dim wshSource As Worksheet
  If Not Intersect(Target, Range("B12,B13")) Is Nothing Then ' You can Change the range here
    Application.EnableEvents = False
    ' Clear G18:G1000
    Range("G18:G1000").ClearContents
    If Range("B12") = "" Or Range("B13") = "" Then
      ' Can'lngTargetRow determine the price range - do nothing
    Else
      Set wshSource = Worksheets("Price Range")
      lngMaxRow = wshSource.Range("A" & wshSource.Rows.Count).End(xlUp).Row
      For lngTargetRow = 18 To 20
        strFruit = Range("A" & lngTargetRow)
        For lngSourceRow = lngMinRow To lngMaxRow
          If wshSource.Range("A" & lngSourceRow) = strFruit And _
              wshSource.Range("C" & lngSourceRow) <= Range("B12") And _
              wshSource.Range("D" & lngSourceRow) >= Range("B12") Then
            Select Case Range("B13")
              Case "Male"
                Range("G" & lngTargetRow) = wshSource.Range("E" & lngSourceRow)
              Case "Female"
                Range("G" & lngTargetRow) = wshSource.Range("H" & lngSourceRow)
            End Select
            Exit For
          End If
        Next lngSourceRow
      Next lngTargetRow
    End If
    Application.EnableEvents = True
  End If
End Sub

The following code copies the product name from the sheet name mentioned in the code to the Receipt sheet.

How could I combine the following code to the above code so that when the product name is written in column A the appropriate price range for the product gets copied from the above code when the "sex" and "age" is changed accordingly.

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Const WS_RANGE As String = "H9" '<== change to suit
    Dim LastRow As Long
    Dim nextRow As Long
    Dim Category As String
    Dim i As Long
     
    On Error GoTo ws_exit
    Application.EnableEvents = False
     
    If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
         
        Me.Range("A15").Resize(1000, 7).ClearContents
         
        nextRow = 14
        With Worksheets("OrderData")
             
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            For i = 5 To LastRow
                 
                If .Cells(i, "I").Value2 = Target.Value Then
                     
                    nextRow = nextRow + 1
                    If .Cells(i, "D").Value2 <> Category Then
                         
                        nextRow = nextRow + 1
                        Category = .Cells(i, "D").Value2
                        Me.Cells(nextRow, "D").Value2 = Category
                        Me.Cells(nextRow, "D").Font.Bold = True
                        nextRow = nextRow + 1
                        Me.Cells(nextRow, "A").Value2 = "Product Name"
                        Me.Cells(nextRow, "A").Font.Bold = True
                        Me.Cells(nextRow, "E").Value2 = "Sale"
                        Me.Cells(nextRow, "E").Font.Bold = True
                        Me.Cells(nextRow, "F").Value2 = "Units"
                        Me.Cells(nextRow, "F").Font.Bold = True
                        Me.Cells(nextRow, "G").Value2 = "Price Range"
                        Me.Cells(nextRow, "G").Font.Bold = True
                        nextRow = nextRow + 1
                    End If
                     
                    Me.Cells(nextRow, "A").Value2 = .Cells(i, "E").Value2
                    Me.Cells(nextRow, "A").Font.Bold = False
                       Me.Cells(nextRow, "F").Formula = "=VLOOKUP(A" & nextRow & _
                        ",PriceRange!$A$3:$D$99,2 ,FALSE)"
                        Me.Cells(nextRow, "G").Font.Bold = False

                End If
            Next i
        End With
    End If
   Dim m As Long
    With Worksheets("Reciept")
        m = .Cells(.Rows.Count, 1).End(xlUp).Row
        If Not .Cells(m, 4) = "Thank You" Then
            .Cells(m + 1, 4) = "Thank You"
        End If
    End With
     
ws_exit:
    Application.EnableEvents = True
End Sub

Any help would be kindly appriciated.

[HansV]

Does it help if you change the line

If Not Intersect(Target, Range("B12,B13")) Is Nothing Then ' You can Change the range here

to

If Not Intersect(Target, Range("A:A,B12,B13")) Is Nothing Then ' You can Change the range here

[adam]

I have put the codes into one worksheet module to work them as I have mentioned before. I have attached the sample workbook for reference.

Note: the names of the sheets & and the cell reference might differ in the codes that I have first posted. But the concept is the same.

Please let me know what I have done wrong in here.

[HansV]

I don't understand what you're trying to do. You appear to be mixing two pieces of code with completely different purposes.

There's one error that is immediately noticeable. If a sheet name contains spaces, you must enclose it in single quotes in formulas. So the lines

Code: Select all

                       Me.Cells(NextRow, "C").Formula = "=VLOOKUP(A" & NextRow & _
                        ",Price Range!A4:K12,11 ,FALSE)"

should be

Code: Select all

                       Me.Cells(NextRow, "C").Formula = "=VLOOKUP(A" & NextRow & _
                        ",'Price Range'!A4:K12,11 ,FALSE)"

Otherwise, the formulas will return #NAME?

[adam]

I have worked-out the code to suite my need and I’m happy for that. But there’s a minor change that’s needed to be changed.

When the accession number is written in the cell as A0002 from A0001 and either the “sex” or “age” is changed, the heading “reference range” disappears. What might be the reason for this?

When the content in the cell “B2” is cleared all the data in the sheet gets cleared. But the text “Thank you” does not. What could be the reason for this?

I’ve attached the workbook for reference.

I would be happy if you could let me know what I had done wrong in here.

[HansV]

When I try it, the heading doesn't disappear (it is recreated by the code), but your code doesn't write any data below the heading (nor in column B).

The line

Me.Range("A4").Resize(1000, 4).ClearContents

clears A4:D1003, but you have code lower down that writes "Thank you" again:

.Cells(m + 1, 4) = "Thank You"

You could use an If ... End If block to that only if cell B2 is not blank.

[adam]

You could use an If ... End If block to that only if cell B2 is not blank.

I would be happy if you could explain in more detail.

Thanks in advance.

[HansV]

Put

If Not Range("B2") = "" Then

before, and

End If

after the lines that fill a cell with "Thank you".

[adam]

Put

If Not Range("B2") = "" Then

before, and

End If

after the lines that fill a cell with "Thank you".

are you referring to put the line before and AFTER the line "End If" that comes after the lines

Code: Select all

Dim m As Long
    With Worksheets("Sales")
        m = .Cells(.Rows.Count, 1).End(xlUp).Row
        If Not .Cells(m, 4) = "Thank You" Then
            .Cells(m + 1, 4) = "Thank You"
            .Cells(m + 1, 4).Font.Bold = True
        End If
    End With
End If
 

if so, here is how I have done so. and the code does not seem to work

Code: Select all

Dim m As Long
    With Worksheets("Sales")
        m = .Cells(.Rows.Count, 1).End(xlUp).Row
        If Not .Cells(m, 4) = "Thank You" Then
            .Cells(m + 1, 4) = "Thank You"
            .Cells(m + 1, 4).Font.Bold = True
  If Not Range("B2") = "" Then
        End If
        If Not Range("B2") = "" Then
    End With
End If
  

Apologies if I'm misunderstanding your reply.

[HansV]

Inserting lines at random obviously won't work. You now have TWO lines

If Not Range("B2") = "" Then

You only need one - above the line

With Worksheets("Sales")

The corresponding

End If

belongs immediately below

End With

[adam]

Do you mean the code when modified will be as follows

Code: Select all

Dim m As Long
    If Not Range("B2") = "" Then
    With Worksheets("Sales")
        m = .Cells(.Rows.Count, 1).End(xlUp).Row
        If Not .Cells(m, 4) = "Thank You" Then
            .Cells(m + 1, 4) = "Thank You"
            .Cells(m + 1, 4).Font.Bold = True
    End With
End If
End If

[HansV]

One of the End Ifs has ended up below the End With. It should be above it. The other one should be below it.

[adam]

I'm sorry it doesn't work either way. I did try putting End if below & above the End with.

[HansV]

Sorry about that.

[adam]

Hey, your code was to clear the text "Thank You" when the contents of the cell "B2" is cleared. Am I right? if its so, it works. What I was also asking was when the sex is either changed to male or female the heading "reference range gets cleared. how to prevent this?