cc9083
05-27-2009, 12:56 AM
Hi there. I have these VBA codes in my worksheet provided by a good member of this forum and would like to tweak it further to suit my current requirement.
With the current VBA, I'm able to insert a new row via a macro button in Sheet 1. Data has to be entered one row at a time to enable the codes to work and when a unique data is identified in Column B, a new row will be added to Sheet 2 & Sheet 3 to accommodate the unique data. The codes will also run on duplicate data but will not create any new row. There is also a delete row button which works vice versa to the insert row button. This button also deletes row one at a time whenever I highlight the cell that will be deleted.
Now, since I'm receiving data from my colleagues in table forms, I’ll just filter the data that I need and copy them into Sheet 1. When I need to enter say 50 rows of data each time I receive them, I’ll insert 50 empty rows with the insert row button then paste the data accordingly. However, the codes doesn't work for "copy and paste” data.
On the other hand, it would be great if there is a dialog box that pops up requesting the number of rows to be inserted instead of adding one row at a time and a delete rows button that works in mass.
Can somebody assist to tweak these codes according to my requirement. The codes are as below. Regards.
Codes in Sheet 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UR As Worksheet
Dim WVPU As Worksheet
If Target.Address <> "$B$5" Or Target.Cells.Count > 1 Then Exit Sub
If Application.CountIf(Columns(2), Target) > 1 Then Exit Sub
Set UR = Sheets(2)
Set WVPU = Sheets(3)
With UR.Range("A6:J6")
.Insert
.Offset(-1).FillDown
End With
With WVPU.Range("A6:T6")
.Insert
.Offset(-1).FillDown
End With
UR.Range("A6") = Target
WVPU.Range("A6") = Target
End Sub
Codes in Module1
Option Explicit
Sub Macro1()
Dim WRN As Worksheet
Set WRN = Sheets(1)
With WRN.Range("A5:D5")
.Insert Shift:=xlDown
.Offset(-1).Interior.ColorIndex = xlNone
End With
End Sub
Sub Macro2()
Dim WRN As Worksheet
Dim UR As Worksheet
Dim WVPU As Worksheet
Dim ToDelete As String
Dim sh As Worksheet
Dim Confirm As Long
Set WRN = Sheets(1)
Set UR = Sheets(2)
Set WVPU = Sheets(3)
ToDelete = WRN.Cells(ActiveCell.Row, 2)
If ToDelete <> "" Then
Confirm = MsgBox("This will delete" & vbCr & _
"Name: " & WRN.Cells(ActiveCell.Row, 2) & vbCr & _
"Job: " & WRN.Cells(ActiveCell.Row, 1), vbYesNo)
If Confirm = vbNo Then Exit Sub
If Application.CountIf(Columns(2), ToDelete) = 1 Then
If ToDelete <> "" Then
UR.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
WVPU.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
End If
End If
End If
ActiveCell.EntireRow.Delete
End Sub
With the current VBA, I'm able to insert a new row via a macro button in Sheet 1. Data has to be entered one row at a time to enable the codes to work and when a unique data is identified in Column B, a new row will be added to Sheet 2 & Sheet 3 to accommodate the unique data. The codes will also run on duplicate data but will not create any new row. There is also a delete row button which works vice versa to the insert row button. This button also deletes row one at a time whenever I highlight the cell that will be deleted.
Now, since I'm receiving data from my colleagues in table forms, I’ll just filter the data that I need and copy them into Sheet 1. When I need to enter say 50 rows of data each time I receive them, I’ll insert 50 empty rows with the insert row button then paste the data accordingly. However, the codes doesn't work for "copy and paste” data.
On the other hand, it would be great if there is a dialog box that pops up requesting the number of rows to be inserted instead of adding one row at a time and a delete rows button that works in mass.
Can somebody assist to tweak these codes according to my requirement. The codes are as below. Regards.
Codes in Sheet 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim UR As Worksheet
Dim WVPU As Worksheet
If Target.Address <> "$B$5" Or Target.Cells.Count > 1 Then Exit Sub
If Application.CountIf(Columns(2), Target) > 1 Then Exit Sub
Set UR = Sheets(2)
Set WVPU = Sheets(3)
With UR.Range("A6:J6")
.Insert
.Offset(-1).FillDown
End With
With WVPU.Range("A6:T6")
.Insert
.Offset(-1).FillDown
End With
UR.Range("A6") = Target
WVPU.Range("A6") = Target
End Sub
Codes in Module1
Option Explicit
Sub Macro1()
Dim WRN As Worksheet
Set WRN = Sheets(1)
With WRN.Range("A5:D5")
.Insert Shift:=xlDown
.Offset(-1).Interior.ColorIndex = xlNone
End With
End Sub
Sub Macro2()
Dim WRN As Worksheet
Dim UR As Worksheet
Dim WVPU As Worksheet
Dim ToDelete As String
Dim sh As Worksheet
Dim Confirm As Long
Set WRN = Sheets(1)
Set UR = Sheets(2)
Set WVPU = Sheets(3)
ToDelete = WRN.Cells(ActiveCell.Row, 2)
If ToDelete <> "" Then
Confirm = MsgBox("This will delete" & vbCr & _
"Name: " & WRN.Cells(ActiveCell.Row, 2) & vbCr & _
"Job: " & WRN.Cells(ActiveCell.Row, 1), vbYesNo)
If Confirm = vbNo Then Exit Sub
If Application.CountIf(Columns(2), ToDelete) = 1 Then
If ToDelete <> "" Then
UR.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
WVPU.Columns(1).Find(ToDelete, lookat:=xlWhole).EntireRow.Delete
End If
End If
End If
ActiveCell.EntireRow.Delete
End Sub