Meatball
08-06-2009, 11:07 AM
I have code here, written by XLD, which looks at a column on a spreadsheet and if it finds a matching part number on a second sheet it inserts info from the second sheet into the first sheet then deletes the matched row from the first sheet
I am wondering if this code can be tweaked so that before deleting the the original row from the spreadsheet, the info in columns B, J ,and K is copied to the first row of the inserted rows.
Thanks in advance for any help
Option Explicit
Public Sub ProcessData()
Static ColourId As Long
Dim i As Long
Dim LastRow As Long
Dim MatchRow As Long
Dim NextRow As Long
Dim wsSets As Worksheet
Dim wbsetlist As Workbook
Workbooks.Open Filename:="C:\Documents and Settings\David D\My Documents\Set expander macro\Test Set list.xls"
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wbsetlist = Workbooks("Test Set list")
Set wsSets = Worksheets("Set List")
ThisWorkbook.Activate
With Worksheets("Before")
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row
For i = LastRow To 1 Step -1
MatchRow = 0
On Error Resume Next
MatchRow = Application.Match(.Cells(i, "k").Value, wsSets.Columns(3), 0)
On Error GoTo 0
If MatchRow > 0 Then
If ColourId = 0 Or ColourId = 37 Then
ColourId = 35
Else
ColourId = ColourId + 1
End If
NextRow = MatchRow + 1
Do
NextRow = NextRow + 1
Loop Until wsSets.Cells(NextRow, "C").Font.Bold = True
.Rows(i + 1).Resize(NextRow - MatchRow).Insert
wsSets.Cells(MatchRow, "B").Resize(NextRow - MatchRow).Copy .Cells(i + 1, "C")
wsSets.Cells(MatchRow, "A").Resize(NextRow - MatchRow).Copy .Cells(i + 1, "i")
.Cells(i + 1, "d").Resize(NextRow - MatchRow).Value = .Cells(i, "d").Value
.Cells(i, "E").Resize(, 2).Copy .Cells(i + 1, "E")
.Cells(i + 1, "d").Value = ""
.Cells(i + 1, "c").Resize(NextRow - MatchRow, 2).Interior.ColorIndex = ColourId
.Rows(i).Delete
End If
Next i
End With
wbsetlist.Close
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
I am wondering if this code can be tweaked so that before deleting the the original row from the spreadsheet, the info in columns B, J ,and K is copied to the first row of the inserted rows.
Thanks in advance for any help
Option Explicit
Public Sub ProcessData()
Static ColourId As Long
Dim i As Long
Dim LastRow As Long
Dim MatchRow As Long
Dim NextRow As Long
Dim wsSets As Worksheet
Dim wbsetlist As Workbook
Workbooks.Open Filename:="C:\Documents and Settings\David D\My Documents\Set expander macro\Test Set list.xls"
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wbsetlist = Workbooks("Test Set list")
Set wsSets = Worksheets("Set List")
ThisWorkbook.Activate
With Worksheets("Before")
LastRow = .Cells(.Rows.Count, "c").End(xlUp).Row
For i = LastRow To 1 Step -1
MatchRow = 0
On Error Resume Next
MatchRow = Application.Match(.Cells(i, "k").Value, wsSets.Columns(3), 0)
On Error GoTo 0
If MatchRow > 0 Then
If ColourId = 0 Or ColourId = 37 Then
ColourId = 35
Else
ColourId = ColourId + 1
End If
NextRow = MatchRow + 1
Do
NextRow = NextRow + 1
Loop Until wsSets.Cells(NextRow, "C").Font.Bold = True
.Rows(i + 1).Resize(NextRow - MatchRow).Insert
wsSets.Cells(MatchRow, "B").Resize(NextRow - MatchRow).Copy .Cells(i + 1, "C")
wsSets.Cells(MatchRow, "A").Resize(NextRow - MatchRow).Copy .Cells(i + 1, "i")
.Cells(i + 1, "d").Resize(NextRow - MatchRow).Value = .Cells(i, "d").Value
.Cells(i, "E").Resize(, 2).Copy .Cells(i + 1, "E")
.Cells(i + 1, "d").Value = ""
.Cells(i + 1, "c").Resize(NextRow - MatchRow, 2).Interior.ColorIndex = ColourId
.Rows(i).Delete
End If
Next i
End With
wbsetlist.Close
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub