PDA

View Full Version : Code to insert info needs tweaking



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

mdmackillop
08-06-2009, 01:42 PM
Can you post some sample data?

Meatball
08-06-2009, 02:01 PM
Please see attachment. I highlighted the info that is being lost on the Before Tab and where it should be on the After tab.

mdmackillop
08-06-2009, 02:28 PM
The sample does not contain data in the columns needed to run it.

Meatball
08-07-2009, 05:43 AM
Ooops, forgot that the original sample provided to create the code had been altered. The following code should match the sample workbook.

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:="Z:\Gould Southern Info\Tool & Desc Lookup\Tool # & Desc Finders\ab. TOOL SET List.xls"
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wbsetlist = Workbooks("ab. TOOL SET List")
Set wsSets = Worksheets("Set List")
ThisWorkbook.Activate
With Worksheets("--Jimmy-Cost--")

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 SaveChanges:=False

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

Meatball
08-13-2009, 09:12 AM
Still looking for help on this one. By the way another option would be that the info pasted into the original sheet could overwrite the info that is there as long as the rest of the columns are not overwritten.

mdmackillop
08-13-2009, 11:45 AM
Set wsSets = Worksheets("Set List")
ThisWorkbook.Activate
With Worksheets("--Jimmy-Cost--")

These sheets don't exist in your sample. Please put together a Workbook with "working" code.

Meatball
08-13-2009, 12:35 PM
mdmackillop, thanks for taking the time to look at this.
Since my current code actually works with pulling info from a seperate workbook I have made samples of before, after, and the list of sets. It appears I will have to use 3 seperate posts to include them all. The before and after workbooks still have the code in them but I will add it to this post just in case.

When starting this project I was told that using "the next bold line" was not a good way to find the last line of a set so I have since added the info in column C of the set list. If you think it would be easier to re-wite most or all of the code to get the final results I have no problem with that.

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:="Z:\Gould Southern Info\Tool & Desc Lookup\Tool # & Desc Finders\ab. TOOL SET List.xls"
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wbsetlist = Workbooks("ab. TOOL SET List")
Set wsSets = Worksheets("Set List")
ThisWorkbook.Activate
With Worksheets("--Jimmy-Cost--")

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

End If
Next i

End With
wbsetlist.Close SaveChanges:=False

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub



Thanks again for looking at this

Meatball
08-13-2009, 12:38 PM
2nd file

Meatball
08-13-2009, 12:39 PM
last file

mdmackillop
08-13-2009, 02:13 PM
You should comment your code to explain the steps. I've no time now to decipher what is required.