ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Conditional copy and row insert based on criteria (https://www.excelbanter.com/excel-programming/444008-conditional-copy-row-insert-based-criteria.html)

[email protected]
Conditional copy and row insert based on criteria
 
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[_2_]
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

WeitWinkel
Conditional copy and row insert based on criteria
 
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(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



On Dec 12, 5:00*pm, Per Jessen wrote:
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

Per Jessen[_2_]
Conditional copy and row insert based on criteria
 
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

On 13 Dec., 01:58, WeitWinkel wrote:
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(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

On Dec 12, 5:00*pm, Per Jessen wrote:



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- Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -

WeitWinkel
Conditional copy and row insert based on criteria
 
On Dec 12, 9:03*pm, Per Jessen wrote:
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

On 13 Dec., 01:58, WeitWinkel wrote:

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(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

On Dec 12, 5:00*pm, Per Jessen wrote:

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- Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -

GENIUS! You just made my day!


All times are GMT +1. The time now is 02:49 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com