To the attention of Rick Rothstein, please for advice

[K0st4din]

Hello, after a while, I need some help from you.
This macro is written by you, and to this day it helps me a lot.
Every time I open the table and press the button I remember you and your help.


Please for your help, if it is possible to help me change the macro a bit.
Ie to work the same way - to take the information from sheet1 but to transfer the information to a specific sheet, for example in a sheet called "Peaches"

If you have questions, I am at your disposal.
Thank you in advance

Private Sub CommandButton4_Click()
Dim x As Long, Cell As Range, CellText As String, ws As Worksheet
  Dim Words As Variant, Replacements As Variant
  Const TableSheetName As String = "Sheet1"
  Application.Volatile
  Words = Sheets(TableSheetName).Range("V2", Sheets(TableSheetName).Cells(Rows.Count, "V").End(xlUp))
    Replacements = Sheets(TableSheetName).Range("W2", Sheets(TableSheetName).Cells(Rows.Count, "W").End(xlUp))
    For Each ws In Worksheets 'I think something needs to be changed here to not list all the sheets, but I'm not sure
    lTotalRows = ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp)).Rows.Count
    For Each Cell In ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp))
    'ProgressBar2.Value = Int(100 * (Cell.Row - 1) / lTotalRows)
    DoEvents
    CellText = ""
      For x = 1 To UBound(Words)
        If InStr(1, Cell.Value, Words(x, 1), vbTextCompare) Then CellText = CellText & "+" & Replacements(x, 1) 'If Cell.Value = Words(X, 1)
      Next
      Cell.Offset(, 6).Value = Mid(CellText, 2) 'PARI P
    Next
  Next
  'ProgressBar2.Value = 100
  'ProgressBar2.Visible = False
End Sub

 

[Rick Rothstein]

Hello, after a while, I need some help from you.
This macro is written by you, and to this day it helps me a lot.
Every time I open the table and press the button I remember you and your help.


Please for your help, if it is possible to help me change the macro a bit.
Ie to work the same way - to take the information from sheet1 but to transfer the information to a specific sheet, for example in a sheet called "Peaches"

If you have questions, I am at your disposal.
Thank you in advance

Private Sub CommandButton4_Click()
Dim x As Long, Cell As Range, CellText As String, ws As Worksheet
  Dim Words As Variant, Replacements As Variant
  Const TableSheetName As String = "Sheet1"
  Application.Volatile
  Words = Sheets(TableSheetName).Range("V2", Sheets(TableSheetName).Cells(Rows.Count, "V").End(xlUp))
    Replacements = Sheets(TableSheetName).Range("W2", Sheets(TableSheetName).Cells(Rows.Count, "W").End(xlUp))
    For Each ws In Worksheets 'I think something needs to be changed here to not list all the sheets, but I'm not sure
    lTotalRows = ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp)).Rows.Count
    For Each Cell In ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp))
    'ProgressBar2.Value = Int(100 * (Cell.Row - 1) / lTotalRows)
    DoEvents
    CellText = ""
      For x = 1 To UBound(Words)
        If InStr(1, Cell.Value, Words(x, 1), vbTextCompare) Then CellText = CellText & "+" & Replacements(x, 1) 'If Cell.Value = Words(X, 1)
      Next
      Cell.Offset(, 6).Value = Mid(CellText, 2) 'PARI P
    Next
  Next
  'ProgressBar2.Value = 100
  'ProgressBar2.Visible = False
End Sub

It appears that you may have modified whatever code I wrote back then. I declare (Dim) all of my variables and I see you have a variable named lTotalRows that is undeclared. Also, you can remove the Application.Volatile code line as that would only apply to a UDF (user defined function), not a non-function procedure. Also, I am not sure that the DoEvents is needed either. With that said, to answer your question, I think you would need to change this line of code...

Cell.Offset(, 6).Value = Mid(CellText, 2) 'PARI P

to something like this...

Sheets("Peaches").Cells(Cell.Row, "P").Value = Mid(CellText, 2) 'PARI P

where you would change the "P" to the column letter designation on sheet "Peaches" where the output is to go to.

 

[K0st4din]

Hello,
I think I do not do the right thing.
For a moment, I've placed quotes to stop the things you describe in the macro. But the result that shows me is very different from what I have to get.
And taking into account that I'm not very good with macros, I'm not sure what to do.
I ask you to look at where I'm mistaken.

Sub proba_pari_za_edin_sheet()
Dim x As Long, Cell As Range, CellText As String, ws As Worksheet
  Dim Words As Variant, Replacements As Variant
  Const TableSheetName As String = "Sheet1"
  'Application.Volatile 'I STOP THIS
  Words = Sheets(TableSheetName).Range("V2", Sheets(TableSheetName).Cells(Rows.Count, "V").End(xlUp))
    Replacements = Sheets(TableSheetName).Range("W2", Sheets(TableSheetName).Cells(Rows.Count, "W").End(xlUp))
    'For Each ws In Worksheets ' AND THIS
    'lTotalRows = ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp)).Rows.Count ' AND THIS
    For Each Cell In ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp))
    'ProgressBar2.Value = Int(100 * (Cell.Row - 1) / lTotalRows)
    DoEvents
    CellText = ""
      For x = 1 To UBound(Words)
        If InStr(1, Cell.Value, Words(x, 1), vbTextCompare) Then CellText = CellText & "+" & Replacements(x, 1) 'If Cell.Value = Words(X, 1)
      Next
      Sheets("OPL").Cells(Cell.Row, "P").Value = Mid(CellText, 2) 'PARI P Cell.Offset(, 6).Value = Mid(CellText, 2) 'PARI P
    Next
  Next
  'ProgressBar2.Value = 100
  'ProgressBar2.Visible = False
End Sub

Must be:

Now is:

 

[K0st4din]

Hello,
almost all night trying, but obviously I can not see where my mistake is.
To get the same numbers, for different products, I think the macro something misses. I have the feeling that I get the first product I encounter and put the number (its) for everyone else.

 

[K0st4din]

I will send you testing file.
In "Sheet1" is a base, column V & W
In sheet "OPL" column J2:J is a words, in P2:P - price

for 1 sheet (test file)

Does this - Cell.Offset (, 6)- give us the problem?

I tried to change, but immediately gave me an error

[COLOR=#333333]Sheets("OPL").Cells(Cell.Row, "P").Value = Mid(CellText, 2)[/COLOR]

i change with this, but not working

[COLOR=#333333]Sheets("OPL").Cells(Cell.Offset (, 6)).Value = Mid(CellText, 2)[/COLOR]

 

[Rick Rothstein]

I will send you testing file.

for 1 sheet (test file)

That website requires one to sign up for an account in order to download the file. Sorry, but I do not plan to do that. Try using DropBox (the Basic plan) instead.

 

[K0st4din]

Link dropbox: https://www.dropbox.com/s/qsubryk9jydzeme/for 1 sheet.xls?dl=0

 

[Rick Rothstein]

Link dropbox: https://www.dropbox.com/s/qsubryk9jydzeme/for 1 sheet.xls?dl=0

Besides adding the functionality you wanted, I reworked the code so that I think it should be fast enough not to require you to display a progress report. The following code will ask you the name of the worksheet to process... the code assumes that worksheet has the values to replace already listed in Column J on it (output will go to Column P).

[table="width: 500"]
[tr]
	[td]Sub proba_pari_za_edin_sheet()
  Dim X As Long, Z As Long, Answer As String, OutSheet As Worksheet, Parts() As String
  Dim DataFind As Variant, DataReplace As Variant, ResultData As Variant
  Const DataSheet As String = "Sheet1"
  DataFind = Sheets(DataSheet).Range("V1", Sheets(DataSheet).Cells(Rows.Count, "V").End(xlUp))
  DataReplace = Sheets(DataSheet).Range("W1", Sheets(DataSheet).Cells(Rows.Count, "W").End(xlUp))
  On Error GoTo NoSuchSheet
  Set OutSheet = Sheets(InputBox("What sheet do you want the output to go to?", vbQuestion))
  On Error GoTo 0
  ResultData = OutSheet.Range("J1", OutSheet.Cells(Rows.Count, "J").End(xlUp))
  On Error Resume Next
  For X = 1 To UBound(ResultData)
    Parts = Split(ResultData(X, 1), "+")
    For Z = 0 To UBound(Parts)
      Parts(Z) = Application.Lookup(Parts(Z), DataFind, DataReplace)
    Next
    ResultData(X, 1) = Join(Parts, "+")
  Next
  OutSheet.Range("P1").Resize(UBound(ResultData)).NumberFormat = "@"
  OutSheet.Range("P1").Resize(UBound(ResultData)) = ResultData
  On Error GoTo 0
  Exit Sub
NoSuchSheet:
  MsgBox "That sheet name does not exist!", vbCritical
End Sub[/td]
[/tr]
[/table]

 

[K0st4din]

Hello,
this is a pretty changed macro, but it's perfect.
And that idea to ask me in which sheet to put the calculation is incredible.
I have not thought about it.
You are an incredible person and I will remember each other again for you when working with the table.
I made minor changes to the macro to start from the second row, because the first row is a constant and the formatting of the text "@" made it "General" because if it is text, I can not calculate it.
No matter how much I say, there will be a little bit of help on your part.
Be always so responsive.
Be alive and healthy.

 

[K0st4din]

Hello Rick Rothstein,
again to repeat that the macro is unique.
I was impressed that he worked better than the old one.
I ask you very much for your help, if you can add my option to me in which worksheets to put prices on.
I mean Array ("Peaches", "Apricots", etc.)

I beg you, because I really did notice that it works much more correctly.
Thank you with all my heart.
Be alive and healthy.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub proba_pari_za_edin_sheet()
  Dim X As Long, Z As Long, Answer As String, OutSheet As Worksheet, Parts() As String
  Dim DataFind As Variant, DataReplace As Variant, ResultData As Variant
  Const DataSheet As String = "Sheet1"
->>>>>>>>>>>>>> How to Add Array("Peaches", "Apricots", "ect...")
  DataFind = Sheets(DataSheet).Range("V1", Sheets(DataSheet).Cells(Rows.Count, "V").End(xlUp))
  DataReplace = Sheets(DataSheet).Range("W1", Sheets(DataSheet).Cells(Rows.Count, "W").End(xlUp))
  On Error GoTo NoSuchSheet
  Set OutSheet = Sheets(InputBox("What sheet do you want the output to go to?", vbQuestion))
  On Error GoTo 0
  ResultData = OutSheet.Range("J1", OutSheet.Cells(Rows.Count, "J").End(xlUp))
  On Error Resume Next
  For X = 1 To UBound(ResultData)
    Parts = Split(ResultData(X, 1), "+")
    For Z = 0 To UBound(Parts)
      Parts(Z) = Application.Lookup(Parts(Z), DataFind, DataReplace)
    Next
    ResultData(X, 1) = Join(Parts, "+")
  Next
  OutSheet.Range("P1").Resize(UBound(ResultData)).NumberFormat = "@"
  OutSheet.Range("P1").Resize(UBound(ResultData)) = ResultData
  On Error GoTo 0
  Exit Sub
NoSuchSheet:
  MsgBox "That sheet name does not exist!", vbCritical
End Sub[/TD]
[/TR]
</tbody>[/TABLE]