Run macro for selected rows

[ced0802]

Hi everyone,

I would like this macro to run, for the rows that I am selecting :


Sub Copypaste()
For x = 1 To 10000

If x = ThisWorkbook.Worksheets("sheet1").Cells(2, 11) Then
ThisWorkbook.Worksheets("sheet1").Cells(13, 1) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 1)
ThisWorkbook.Worksheets("sheet1").Cells(13, 5) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 2)
ThisWorkbook.Worksheets("sheet1").Cells(13, 2) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 6)
ThisWorkbook.Worksheets("sheet1").Cells(13, 3) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 7)
ThisWorkbook.Worksheets("sheet1").Cells(13, 4) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 5)
ThisWorkbook.Worksheets("sheet1").Cells(13, 7) = Workbooks("List Of materials").Worksheets("Sheet1").Cells(x, 9)
Range("A2:D2").Select
ActiveCell.FormulaR1C1 = "NAME OF PERSON REQUESTING WRITE OFF: "Ced"

ThisWorkbook.Worksheets("sheet1").Cells(4, 1) = "DATE : " & "" & Date

End If
Next x
End Sub



It is a copy paste of some cells on the lines I would select.

Thank you very much for your help.

[SamT]

Run the Sub from the Tools Macro menu, Add a Command Button to the Worksheet, or add a Menu Item to the Workbook

[ced0802]

Hi,

Sorry for not ginving much details.
I have two files : - first file called "WO-clean with lines" where I'd like to paste information on row 13
- second file called "List of Materials" where I'd like to copy some information from a row. But I don't want to copy the whole row, just a few cells from the row.

GOAL : I select a row from "List of Materials" then I go back to "thisworkbook" to run my macro, and information are pasting into my chart.
This is where I am so far :



Sub Copypaste()

Set Final = ThisWorkbook.Worksheets("Sheet1")
Set Init = Workbooks("List Of materials").Worksheets("Sheet1")

LigneAvecUnPetitNom = ActiveCell.EntireRow.Row

For x = 1 To 10000
For y = 13 To 27
If x = LigneAvecUnPetitNom Then
Final.Cells(y, 1) = Init.Cells(x, 1)
Final.Cells(y, 2) = Init.Cells(x, 6)
Final.Cells(y, 3) = Init.Cells(x, 7)
Final.Cells(y, 4) = Init.Cells(x, 5)
Final.Cells(y, 5) = Init.Cells(x, 2)
Final.Cells(y, 7) = Init.Cells(x, 9)

Range("A2:D2").FormulaR1C1 = "NAME OF PERSON REQUESTING WRITE OFF: Ced"

Final.Cells(4, 1) = "DATE : " & "" & Date



Exit Sub

End If
Next y
Next x


End Sub


It's not working properly as when I go back to "thisworkbook" to run my macro it copies the row from "List of materials" from the row of the cell selected in "thisworkbook"

Hope it is a bit clearer :)

Thanks A LOT for your help

[SamT]

Put this code in the List of Materials, ThisWorkbook Code page
Private mSelectedSheet As String
Private mSelectedRow As Long

Private Sub Workbook_SheetSelectionChange(ByVal Sht As Object, ByVal Target As Range)
mSelectedSheet = Sht.Name
mSelectedRow = Target.Row
End Sub

Public Property Get SelectedSheet() As String
SelectedSheet = mSelectedSheet
End Property

Public Property Get SelectedRow() As Long
SelectedRow = mSelectedRow
End Property



Use this CopyPasteSub in a standard module in the main workbook
Sub Copypaste()

Set Final = ThisWorkbook.Worksheets("Sheet1")
Set Lom = Workbooks("List Of materials")
Set Init = Lom.Worksheets(Lom.SelectedSheet)

x = Lom.SelectedRow
y = Final.Cells(Rows.Count, 1).End(xlUp).Row + 1
If y < 13 Then y = 13
If y > 27 then
MsgBox "this Request for Writeoff is full, Please save and use a new one"
Exit Sub
End If

Final.Cells(y, 1) = Init.Cells(x, 1)
Final.Cells(y, 2) = Init.Cells(x, 6)
Final.Cells(y, 3) = Init.Cells(x, 7)
Final.Cells(y, 4) = Init.Cells(x, 5)
Final.Cells(y, 5) = Init.Cells(x, 2)
Final.Cells(y, 7) = Init.Cells(x, 9)

Final.Range("A2") = "NAME OF PERSON REQUESTING WRITE OFF: Ced"

Final.Cells(4, 1) = "DATE : " & Date


End Sub

[ced0802]

Thank you very much for your code and the time you put.

I have a message error on

Set Init = Lom.Worksheets(Lom.SelectedSheet)

To be honnest I don't know what "Lom" is..

Thank you again!

[ced0802]

I have this so far, which isworking. But it takes into account the row I have selected in "thisworkbook" and not in "List Of materials"



Sub Copypaste()
Dim Y As Integer
Dim Final As Worksheet, Init As Worksheet
Dim InitWB As Workbook, FinalWB As Workbook
Dim LastColumn_init As Integer, LastColumn_Final As Integer

Dim SelectedRange As Range

Set InitWB = Workbooks("List Of materials")
Set FinalWB = Workbooks("Write-off - clean with lines")

Set InitWS = InitWB.Worksheets("Sheet1")
Set FinalWS = FinalWB.Worksheets("Sheet1")

Set SelectedRange = Selection
LastColumn_itit = 9



For Each RowInSelection In SelectedRange.Rows
For Y = 13 To 27
If IsEmpty(FinalWB.Worksheets(FinalWS.Name).Cells(Y, 1)) Then
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 1) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 1)
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 2) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 6)
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 3) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 7)
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 4) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 5)
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 5) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 2)
FinalWB.Worksheets(FinalWS.Name).Cells(Y, 7) = InitWB.Worksheets(InitWS.Name).Cells(RowInSelection.Row, 9)
Exit For
End If
Next Y
Next RowInSelection

If Y - 13 > SelectedRange.Rows.Count Then MsgBox ("Error: The selected range or the selected range plus existing data contains more than (Y =) 27 - 13 rows" & vbCr & "Not all rows from selection were copied")
End Sub



Any idea how to transfer my selection/

Thank you!!

[SamT]

List of materials

[ced0802]

Ok so with Sam T macro, it is working :) But if I select one line.
I'm trying for 2 lines or more, but it's another story.

Thank you so much to all of you.

[SamT]

What is the maximum number of lines you want to select?
What is the maximum number of lines you can put on one sheet in "Write-off - clean with lines?"
What do you want to happen if you select more lines that will fit on one sheet?

[ced0802]

Maximum line would be 8.
on Write off can put 12.
I want the same thing that this macro is doing for one line. The 2nd line selected would be pasted underneath the previous one on my main workbook
Thank you.

[SamT]

When you select from the List of materials, is it a block of materials or is the selection random items?
In other words, do you select, for example, rows 1, 5, & 16?

[ced0802]

Hi,

Thank you for your message. No it would be a block (like row5,6,7,8,9).

[alansidman]

crossposted at: http://www.excelforum.com/excel-programming-vba-macros/1120595-run-macro-for-selected-rows.html

[ced0802]

My apoologies for the crossposted. Will edit on other forum.

[SamT]

Replace the two subs in Post #4 with these

Private mSelectedSheet As String 'm prefix indicate module level variable
Private mSelectedRows As String

Private Sub Workbook_SheetSelectionChange(ByVal Sht As Object, ByVal Target As Range)
'Last needed column is I (9)
mSelectedSheet = Sht.Name
mSelectedRows = Target.EntireRow.Resize(Selection.Rows.Count, 9).Address
End Sub

Public Property Get SelectedSheet() As String
'To pass sheet name to caller
SelectedSheet = mSelectedSheet
End Property

Public Property Get SelectedRows() As String
SelectedRows = mSelectedRows
End Property




Sub Copypaste()

Set Final = ThisWorkbook.Worksheets("Sheet1")
Set Lom = Workbooks("List Of materials")
Set Init = Lom.Worksheets(Lom.SelectedSheet) 'SelectedSheet calls for sheet name

Set LomSelection = Init.Range(Lom.SelectedRows) 'SelectedRows calls for range address
Y = Final.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Y < 13 Then Y = 13
If Y > 25 Then
MsgBox "this Request for Writeoff is full, Please save and use a new one"
Exit Sub
End If

For X = 1 To LomSelection.Rows.Count
Final.Cells(Y, 1) = LomSelection.Cells(X, 1)
Final.Cells(Y, 2) = LomSelection.Cells(X, 6)
Final.Cells(Y, 3) = LomSelection.Cells(X, 7)
Final.Cells(Y, 4) = LomSelection.Cells(X, 5)
Final.Cells(Y, 5) = LomSelection.Cells(X, 2)
Final.Cells(Y, 7) = LomSelection.Cells(X, 9)
Y = Y + 1
If Y > 25 Then Exit For 'Bottom used row of WriteOff
Next X

Final.Range("A2") = "NAME OF PERSON REQUESTING WRITE OFF: Ced"

Final.Cells(4, 1) = "DATE : " & Date


End Sub

[ced0802]

Woa working perfectly.

A HUGE Thank you to you SamT. I am going to try to understand how you did. I am not very familiar with the first part you code..with the private , property get selection..

Thanks a bunch !! Much appreciated.

[SamT]

There are three very special subs that can only be used in Object codes: Property Get, Property Let, and Property Set. Search for help on "Get". Some Objects are Class Modules, VBA UserForms, ThisWorkbook and Worksheets.

Module level Variables stay active as long as the code is running. The Worksheet_SelectionChange Sub directly sets the Module Variable's Values, and they stay active. When the CopyPaste Sub "Calls" for the Properties (Property Get Subs) the Module Variable Values are returned.

Their purpose is to allow for consistent code. Just as you can write code to set a Variable to a Range's Value
X = Range("A1")You can write Property Subs so that the rest of your code was simplified.

For example, suppose you had a Property Sub in ThisWorkbook

Property Let RequesterName (ReqName As String)
Sheets("Sheet1")Range("A2").Value = ReqName
End SubYou could write code like

ThisWorkbook.RequesterName = "NAME OF PERSON REQUESTING WRITE OFF: Ced"

Not very interesting, but suppose that you always wanted that to be just below the bottom right cell of the data

Property Let RequesterName (ReqName As String)
With Sheets("Sheet1").Range(A1").CurrentRegion
.Cells(.CellsCount).Offset(1, 0) = ReqName
End Sub

Still not too interesting, but assume that you have a parts book with several sheets of part in it. You have code in the parts book to copy selected parts to your Final Sheet in another book("WriteOffs)

In WriteOffs, ThisWorkbook Code Page, you have this code

Property Let NextItem(NewItem As Range)

Set NextRow = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).OffSet(1, -1).Resize(1, 7)
'Rows.Count, 2 for column B. Column A is not used in this example
'Offset(1, - 1) because NextRow below starts in Column A

With NextRow
.Cells(2) = NewItem.Cells(6)
.Cells(3) = NewItem.Cells(7)
.Cells(4) = NewItem.Cells(5)
.Cells(5) = NewItem.Cells(2)
.Cells(7) = NewItem.Cells(9)
End Sub

In your Parts book ThisWorkbook Code Page you have this code

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Cancel = True
Workbooks("WriteOffs.xlsm").NextItem = Target.EntireRow
End Sub

Those two pieces of code will let you wander from Sheet to Sheet in the Parts book, doubleclicking any cell in them to add those items to the WriteOffs Sheet, one after the other.