Excelvba macro

Last Edited By Krjb Donovan
Last Updated: Mar 05, 2014 09:29 PM GMT

Question

QUESTION: I have a Price List Order Form with 3 columns A,B,K and 47 rows from 4:51. If a Qty is entered in any cell in Col K, I want the copy all the data in the 3 rows to the next empty row in a range on the same sheet starting at R16 to R34 in cols R, S ,T. Then save the file to a filename by text in a cell S7, then clear all data contents but not formulas. Thank you for any help

ANSWER: * Put this code in the worksheet module. change sheet names as necessary.


Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo errhandler

If Not Intersect(Target, ThisWorkbook.Worksheets("sheet1").Range("K:K")) Is Nothing Then '(if the cell being changed is in column K)

Dim destination1 As Range Set destination1 = ThisWorkbook.Worksheets("sheet1").Range("R1000000").End(xlUp).Offset(1, 0) '(next available row that's blank at in col. K, it is up to you where the data is)

Target.Offset(0, -10).Copy destination1 Target.Offset(0, -9).Copy destination1.Offset(0, 1) Target.Copy destination1.Offset(0, 2)


Dim myfilename As String myfilename = ThisWorkbook.Worksheets("sheet1").Range("s7").Value Application.DisplayAlerts = False ThisWorkbook.SaveAs (myfilename) Application.DisplayAlerts = True 'this saves it in the current, OR the default directory, I forget which. 'Unless of course, in s7, there is a full mapped path like C:\ 'If this isn't acceptable, re-think your question and ask again

End If


Exit Sub errhandler: MsgBox "Please note the following error:" & vbNewLine & vbNewLine & _

       "Error #:  " & Err.Number & vbNewLine & "Error Description:  " & Err.Description, vbCritical, "  "

Exit Sub End Sub

---------- FOLLOW-UP ----------

QUESTION: Hi again...sorry I missed a : and a . ( couldn't see them!). I have corrected the code and complied it again, now there is a syntax error on the first line of: MsgBox "Please note the following error." & vbNewLine & vbNewLine &_

   "Error# "&Err.Number & vbNewLine & "Error Description: " 

&Err.Description, vbCritical,""


ANSWER: *

You need to copy and paste the code. It works, I've tested it.

---------- FOLLOW-UP ----------

QUESTION: Thank you so much and please forgive my ignorance. I have copied and pasted the code and it now compiles fine. When run, I get an error 424 in the message box"Object required", no data is placed on the quote form and nothing prints although there is a file in the print queue. I cannot see how the code is asking for data in cols A,B,F,G,H,I,J,K in any or rows 4:51 and pasting this to next empty rows in cols W,X,Y,Z,AA,AB,AC in rows 16:34. Here is the exact code :

On Error GoTo errhandler
If Not Intersect(Target, 

ThisWorkbook.Worksheets("Quotation").Range("F4:F51")) Is Nothing Then

'if cell being changed is in col F
   Set QuoteLines = 

ThisWorkbook.Worksheets("Quotation").Range("V:AC").End(xlUp) .Offset(1, 0)

   'next available row that's blank at in col F it is up to 

you where the data is

    Target.Offset(0, -10).Copy QuoteLines
    Target.Offset(0, -9).Copy QuoteLines.Offset(0, 1)
    Target.Copy QuoteLines.Offset(0, 2)
         

errhandler: MsgBox "Please note the following error:" & vbNewLine & vbNewLine & _

      "Error #:  " & Err.Number & vbNewLine & "Error 

Description: " & Err.Description, vbCritical, " " End If

I know it is soooo close! Thank you again

Answer

When I copy and paste the code from this webpage, there are all kinds of syntax and line break errors.

However, you are setting a variable without declaring it.

I would say

Dim quotelines as Range

that line should come before the Set statement first of all.

Also, you just said columns A, B and K in your original question, now the columns are A,B,F,G,H,I,J,K  ??

You should probably just keep your data together so that you can use EntireRow in your code. I'm really lost on what you're trying to do, this idea of only going to certain rows, 16:34 doesn't make sense to me, how can you restrict the rows if you want data to keep being appended as long as necessary?

Advertisement

©2017 eLuminary LLC. All rights reserved.