View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Per Jessen[_2_] Per Jessen[_2_] is offline
external usenet poster
 
Posts: 703
Default Conditional copy and row insert based on criteria

This should do it:

Sub ConditionalCopy()
Dim Source As Worksheet
Dim Dest As Worksheet
Dim sourceRng As Range
Dim CopyRng As Range
Dim DestCell As Range
Dim CritArr

Set Source = Worksheets("Sheet1")
Set Dest = Worksheets("Sheet2")
CritArr = Dest.Range("A2", Dest.Range("A2").End(xlDown)).Value
Set sourceRng = Source.Range("A1", Source.Range("D1").End(xlDown))
Set CopyRng = sourceRng.Offset(1).Resize(sourceRng.Rows.Count - 1, 4)
Set DestCell = Dest.Range("A1").End(xlDown).Offset(1)
For ca = UBound(CritArr) To LBound(CritArr) Step -1
sourceRng.AutoFilter Field:=4, Criteria1:=CritArr(ca, 1)
Debug.Print DestCell.Address

DestCell.Resize(CopyRng.SpecialCells(xlCellTypeVis ible).Rows.Count,
1).EntireRow.Insert
Set DestCell = DestCell.End(xlUp).Offset(1)
CopyRng.SpecialCells(xlCellTypeVisible).Copy DestCell
Set DestCell = DestCell.Offset(-1)
Next
sourceRng.AutoFilter
End Sub

Regarsd,
Per

On 12 Dec., 19:05, "
wrote:
Hi Everybody, I was hoping that anybody in this forum could help me
solve my particular vba problem in Excel. I need to add information
from one sheet to the other based on a certain criteria. This is how
my
information looks like:

Sheet "Source"
Code|Description|Explanation|RollupGroup
AA|Color:Green|ColorCodeA45|10
AB|Fabric:Cotton|NoStretch|10
AD|Pattern:Nuendo|ReferenceAD12|10
BR|Quality:3ply|8907|20
BO|Stitch:4|DoubleCross|20
CA|Yarn:1.2"|6 Threat|30
CF|Length" 23m|Excess .2|30
...
Sheet "Target"
RollupGroup|Description|ISourcetems|Cost
10|Fabric|Fabric Selections|3|12.12
20|Stitching|Stitching Instruction|2|2.33
30|Yarn Selection|2|0.56
...

I need to copy the detail information (entire row) from the source
sheet to the target sheet based on the RollupGroup information.
My new target sheet should then look like this:

Sheet "Target" (After Change)
10|Fabric|Fabric Selections|3|12.12
AA|Color:Green|ColorCodeA45|10
AB|Fabric:Cotton|NoStretch|10
AD|Pattern:Nuendo|ReferenceAD12|10
20|Stitching|Stitching Instruction|2|2.33
BR|Quality:3ply|8907|20
BO|Stitch:4|DoubleCross|20
30|Yarn Selection|2|0.56
CA|Yarn:1.2"|6 Threat|30
CF|Length" 23m|Excess .2|30
...

Anyones help is greatly appreciated!

Regards, Weitwinkel