Conditional copy and row insert based on criteria

[Janetzky]

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

 

[Per Jessen]

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(xlCellTypeVisible).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

 

[WeitWinkel]

Hi Per,

thanks for your great help. See my changes in your code. On the
ubound it is not compiling -Expected Array. What is wrong?

Sub ConditionalCopy()

Dim Source As Worksheet
Dim Dest As Worksheet
Dim sourceRng As Range
Dim CopyRng As Range
Dim DestCell As Range
Dim CritArr As Range
Dim Ca As Double


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(xlCellTypeVisible).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

 

[Per Jessen]

CritArr has to be declared as Variant not as Range which you did.

I declared CritArr implicit as Variant, as a declared variable without
an explicit data type is declared as Variant.

Also, I would declare Ca as Long, because it is an Integer variable.

Per

 

[WeitWinkel]

CritArr has to be declared as Variant not as Range which you did.

I declared CritArr implicit as Variant, as a declared variable without
an explicit data type is declared as Variant.

Also, I would declare Ca as Long, because it is an Integer variable.

Per

GENIUS! You just made my day!