Copy Paste - Columns

sekar_r24 · Jun 24th 2020

HI.,

i am trying to copy & paste the range of columns to two columns with specified criteria., Attached herewith the code so far.

the table consist of 6 columns. the first four columns are code nos with corresponding value in the last two column. i am trying to populate the following.

first column to be placed in a certain location.
the second column to be placed below the first column.
the third column below the second column
the fourth column below the third column.
The value in the fifth column to be placed next column of the first column placed in sl.no:01
the same value is placed again below the values pasted in the sl.no:5.
The value in the sixth column to be placed below the sl.no:06
the same value (sixth column) is placed again below the values pasted in the sl.no:7

the code i tried below, able to achieve upto sl.no:6

Code

Public Sub edgeband()
Dim x As Integer
Dim y As Integer ' column variable
Dim k As Integer ' column variable
Dim m As Integer ' column variable
Dim lngLastRow As Long
Dim lngLast As Long
m = 14
'to find the last row in the column.
'lry = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows,xlPrevious, False).Row
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row
 Z = 13 ' destination column
 x = 3 'row no
y = 6 ' column no
k = 3
' toclear the last row
For y = 6 To 9
Range(Cells(x, y), Cells(lngLastRow, y)).Copy
Cells(k, Z).PasteSpecial xlPasteValues ' destination column
k = Cells(Rows.Count, Z).End(xlUp).Row + 1
Next y
Z = Z + 1
k = 3
For m = m To m + 2
Range(Cells(k, y), Cells(lngLastRow, y)).Copy
Cells(k, Z).PasteSpecial xlPasteValues
k = Cells(Rows.Count, Z).End(xlUp).Row + 1
Cells(k, Z).PasteSpecial xlPasteValues
y = y + 1
m = m + 1
x = 3
k = Cells(Rows.Count, Z).End(xlUp).Row + 1
Next m
Application.CutCopyMode = False[attach=1228611][/attach]
End Sub

Display More

jolivanes · Jun 24th 2020

sl.no:01

sl.no:5.

sl.no:06

sl.no:7

Are these some secret places? Never heard of these before.

jolivanes · Jun 25th 2020

Code

Option Explicit
Sub Maybe()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long
codeArr = Range("F3:I6").Value
lengthArr = Range("J3:K6").Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + 4, 2) = lengthArr(i, j)
Next i
k = k + 4
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
End Sub

Display More

sekar_r24 · Jun 25th 2020

Thanks!. Works perfect.

jolivanes · Jun 26th 2020

Glad you got it working and thanks for letting us know,

Appreciated.

sekar_r24 · Jun 26th 2020

Hi.,

is it possible to filter each unique value, say a1, and copy the corresponding filtered values, sum up the values.

Similarly all the values a2, a3, and a4 are filtered out and copy their corresponding values and sum up..?

How to iterate the values a1, a2, a3 and a4 in autofilter criteria?

jolivanes · Jun 26th 2020

Since you have a very small range, this should do.

Code

Sub Maybe()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long
Application.ScreenUpdating = False
codeArr = Range("F3:I6").Value
lengthArr = Range("J3:K6").Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + 4, 2) = lengthArr(i, j)
Next i
k = k + 4
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
Cells(2, 13).Resize(, 5).Value = Array("EB", "Length", "", "EB", "Total")
Range(Cells(2, 13), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(2, 16), Unique:=True
For j = 3 To Cells(Rows.Count, 16).End(xlUp).Row
For i = 3 To Cells(Rows.Count, 13).End(xlUp).Row
If Cells(i, 13).Value = Cells(j, 16).Value Then Cells(j, 16).Offset(, 1).Value = Cells(j, 16).Offset(, 1).Value + Cells(i, 13).Offset(, 1).Value
Next i
Next j
Application.ScreenUpdating = True
End Sub

Display More

sekar_r24 · Jun 27th 2020

Thanks jolivanes.

Last thing, if there are 'n' number of rows means, how to incorporate in the code.

i tried inserted the following code

Code

lr = Cells(Rows.count, 6).End(xlUp).Row 'counting the no of rows

codeArr = Range("F3:I" & lr).Value ' assigning the no of rows.
lengthArr = Range("J3:K" & lr).Value

but seems it has to be tweaked! could you pls help

sekar_r24 · Jun 27th 2020

Hi

changing the value of ls to the row value work for the n rows . How to assign the variable 'ls' to get the number of rows from the starting cell F3 to the last row in with suitable datatype.

Code

Sub Maybe()
Dim codeArr, lengthArr, resultArr, lr As Long
Dim k As Long, j As Long, i As Long, ls As Long
Application.ScreenUpdating = False
lr = Cells(Rows.count, 6).End(xlUp).Row

ls = 4
codeArr = Range("F3:I" & lr).Value 'range of codes
lengthArr = Range("J3:K" & lr).Value ' range of values

ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4 ' four columns of edgeband
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2 ' two columns of values length and width
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + ls, 2) = lengthArr(i, j)
Next i
k = k + ls
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
Cells(2, 13).Resize(, 5).Value = Array("EB", "Length", "", "EB", "Total")
Range(Cells(2, 13), Cells(Cells(Rows.count, 13).End(xlUp).Row, 13)).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(2, 16), Unique:=True
For j = 3 To Cells(Rows.count, 16).End(xlUp).Row
For i = 3 To Cells(Rows.count, 13).End(xlUp).Row
If Cells(i, 13).Value = Cells(j, 16).Value Then Cells(j, 16).Offset(, 1).Value = Cells(j, 16).Offset(, 1).Value + Cells(i, 13).Offset(, 1).Value
Next i
Next j
Application.ScreenUpdating = True
End Sub

Display More

jolivanes · Jun 27th 2020

Try

Code

Sub Maybe_B()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long, lr As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
Application.ScreenUpdating = False
codeArr = Range("F3:I" & lr).Value
lengthArr = Range("J3:K" & lr).Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + lr - 2, 2) = lengthArr(i, j)
Next i
k = k + lr - 2
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
Cells(2, 13).Resize(, 5).Value = Array("EB", "Length", "", "EB", "Total")
Range(Cells(2, 13), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(2, 16), Unique:=True
For j = 3 To Cells(Rows.Count, 16).End(xlUp).Row
For i = 3 To Cells(Rows.Count, 13).End(xlUp).Row
If Cells(i, 13).Value = Cells(j, 16).Value Then Cells(j, 16).Offset(, 1).Value = Cells(j, 16).Offset(, 1).Value + Cells(i, 13).Offset(, 1).Value
Next i
Next j
Application.ScreenUpdating = True
End Sub

Display More

sekar_r24 · Jun 28th 2020

Thanks a lot jolivanes!

Copy Paste - Columns

Participate now!

Share