Cut &past data from sheet to shhet depending

Hi Sibsanne,

To use the following code, right-click on your master sheets tab and select view code.
Visual Basic will open, now paste the code in the big white field.

I changed the numbers into letters because VB addresses them differently.

One final thing. Codes cannot be reversed using the blue arrows. So it's wise to make a backup first or at least save your file before using the code. Then when you file gets messed up you can reload your file.

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
'The code will only work when a change is made to column H.
If Intersect(Target, Columns("H:H")) Is Nothing Then Exit Sub

'If the value changed into A then cut entire row and paste to sheet A into the first available row.
If ActiveCell = "A" Then Target.EntireRow.Cut Destination:=Sheets("A").Rows(Rows.Count).End(xlUp).Offset(1, 0)
'Same goes for the value B.
If ActiveCell = "B" Then Target.EntireRow.Cut Destination:=Sheets("B").Rows(Rows.Count).End(xlUp).Offset(1, 0)
'Add more statements to complete the code.

End Sub

Best regards,
Trowa

Hi trowad,

Your code is doing his job!

Now that my DB grows and different sheets get filled.
I do see the need for an added function.
When I cut a row to another sheet, it leaves a blank row.
Is it possible to add a line of code that would delete the blank row after it got cut to the new sheet?
So that I have not to do it manually?

Thx.

Sorry for the late response Sibsanne, but here is the adjusted code:

Private Sub Worksheet_Change(ByVal target As Range)
'The code will only work when a change is made to column H.
If Intersect(target, Columns("H:H")) Is Nothing Then Exit Sub

'If the value changed into A then cut entire row and paste to sheet A into the first available row.
If ActiveCell = "A" Then
target.EntireRow.Copy Destination:=Sheets("A").Rows(Rows.Count).End(xlUp).Offset(1, 0)
target.EntireRow.Delete
End If
'Same goes for the value B.
If ActiveCell = "B" Then
target.EntireRow.Copy Destination:=Sheets("B").Rows(Rows.Count).End(xlUp).Offset(1, 0)
target.EntireRow.Delete
End If
'Add more statements to complete the code.

End Sub

Hopefully it will still be usefull.

Best regards,
Trowa

Hi Sibsanne,

It's easier for me to write my own code.

I used column A to determine how many rows to loop through and on sheet "SEARCH" to know which row to copy to. In other words I assumed that when a row contains data then column A of that row always contains data as well.

Note that I have given you a second option to input the search value.
Putting an ' (single quote) in front of a code line makes it green and will be skipped when the code is run. Use this or just delete the code line to choose between option 1 or 2.

Here is the code:

Sub test()
Dim x, y, lRow As Integer
Dim ws As Worksheet

'Option 1: Enter the search value in D4 of sheet "SEARCH".
myText = Sheets("SEARCH").Range("D4").Value

'Option 2: Enter the search value using an inputbox.
'myText = InputBox("Please input the value to search for:")

For Each ws In Worksheets
If ws.Name = "SEARCH" Then GoTo Nxt
ws.Select
lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
x = 1

    Do
    y = 1
Do
If Cells(x, y).Value = myText Then
Rows(x).EntireRow.Copy Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
y = 17
End If
y = y + 1
Loop Until y > 16
    x = x + 1
    Loop Until x > lRow
Nxt:
Next ws

End Sub

Hope you like this little search engine :-)

Best regards,
Trowa

Hi Sibsanne,

Great to see you are getting the hang of this.

To make the code non case sensitive use this line above the "Sub test()" line:

Option Compare Text

code will look like:

Option Compare Text
Sub test()
Dim x, y, lRow As Integer
etc...

Best regards,
Trowa

Thx Trowad!!!

I have all I need now!!

I even managed (by myself !!) to get a VBA working that generate a ready to send email, template filled with data from the excel file, to field, cc field etc. and also with attachment retrieved on network drive... All this in one click based on active cell. This save me a lot of wrist work!!!
I mixed two VBA scripts I found on the net. and after 3 days of seeking frustration, by miracle it worked. (sometime I blocked on things like & instead of = or no = needed..)
That vba languages is very weird one... but ... IT works ;o)

I'm on holiday as from tomorrow, back in january.

I wish you a good new year 2012.