PDA

View Full Version : Copy & Pasting in VBA



Anthon
10-30-2016, 06:24 PM
Hi guys,

I was wondering if you can help me with this problem. I would like to solve this in VBA. Attached is an excel file where Sheet1 is the current state and Sheet2 is what I would like to achieve. Basically, in column A, for each cluster of rows with similar Numbers I will need to insert the same cluster of rows below. The Number will subsequently change to reflect a new starting digit before "-". All digits after "-" is similar to before. In column B, the Value in the inserted rows will be the same as previously, but all to be negative. Finally, in column C, I would just like the exact copy of the Description in the above cells to be pasted in the inserted rows in the same column. You can refer to the excel if I am not doing a good job in explaining my problem. It will be nice to be able to program the highlighting colour for the inserted cells as well. Thank you in advance.

Kenneth Hobs
10-31-2016, 10:32 AM
Be sure to add the reference as detailed in the comment for the first function. Play Main() from activesheet to filter and create the new sheet.

Sub Main()
Dim a() As Variant, v As Variant, r As Range, rr As Range, c As Range
Dim i As Long, ws As Worksheet

Set ws = ActiveSheet

'Get unique values in column A of ws.
Set r = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
a() = WorksheetFunction.Transpose(r)
a() = UniqueArrayByDict(a())
'MsgBox Join(a, vbLf)

Set r = ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)) 'ws's Row 1 column cells
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = "ReMastered Data"
'Copy row 1 column values.
r.Copy .Range("A1")

'Fill ReMasetered Data from ws.
For i = LBound(a) To UBound(a)
Set r = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
ws.UsedRange.AutoFilter 1, a(i)
Set c = StripFirstRow(ws.UsedRange.Cells.SpecialCells(xlCellTypeVisible))
Set r = r.Resize(c.Rows.Count, c.Columns.Count)
c.Copy r

'Copy and format 2nd block from ws.
Set r = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
Set r = r.Resize(c.Rows.Count, c.Columns.Count)
c.Copy r
r.Interior.Color = 14277081

'Change values of Remastered Data's Column B, 2nd block, to negative
For Each c In Intersect(r, r.Columns("B"))
c.Value = c.Value * -1
Next c
Next i

'Autofit ReMastered Data columns
.UsedRange.Columns.EntireColumn.AutoFit
End With

'Clear autofilter
ws.UsedRange.AutoFilter
End Sub

' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
'Dim dic As Object 'Late Binding method - Requires no Reference
'Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
Dim Dic As Dictionary 'Early Binding method
Set Dic = New Dictionary 'Early Binding Method
Dim e As Variant
Dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not Dic.Exists(e) Then Dic.Add e, Nothing
Next e
UniqueArrayByDict = Dic.Keys
End Function


'Kenneth Hobson
Function StripFirstRow(aRange As Range) As Range
Dim i As Long, j As Long, r As Range, z As Long, idx As Long
For i = 1 To aRange.Areas.Count
For j = 1 To aRange.Areas(i).Rows.Count
z = z + 1
If z = 1 Then GoTo NextJ
If r Is Nothing Then
Set r = aRange.Areas(i).Rows(j)
Else
Set r = Union(r, aRange.Areas(i).Rows(j))
End If
NextJ:
Next j
Next i
Set StripFirstRow = r
End Function

Anthon
10-31-2016, 08:37 PM
Hi Kenneth,

Thanks for the reply. Your code works very well. Now I have a slight adaptation to the problem. The Column A Numbers in the inserted rows will now be tagged to the Description. Again, all numbers that occur after "-" is the same as the above cells, but numbers preceding "-" are now to be changed to reflect the alphabet sequence. For eg, if Description states "RECL FOR A" then the number before "-" should be 1. If Description states "RECL FOR B" then the number before "-" should be 2. I have attached the new excel file reflecting what I have just described for your reference. Would appreciate your guidance in this. Thank you.

Kenneth Hobs
10-31-2016, 08:50 PM
Going to sleep now and won't have a chance to work up the exact solution until after noon tomorrow most likely. It is a simple matter though. The key is to use Split(), Ubound(), Join(), and a call to this routine which can all be done in the negative loop.


Function ColumnNumber(sColumnLetter As String) As Integer
ColumnNumber = Cells(1, sColumnLetter).Column
End Function

'FYI, the opposite way...
Function ColumnLetter(ColumnNum As Integer) As String
ColumnLetter = Split(Cells(1, ColumnNum).Address, "$")(1)
End Function

Anthon
11-01-2016, 07:20 PM
Going to sleep now and won't have a chance to work up the exact solution until after noon tomorrow most likely. It is a simple matter though. The key is to use Split(), Ubound(), Join(), and a call to this routine which can all be done in the negative loop.


Function ColumnNumber(sColumnLetter As String) As Integer
ColumnNumber = Cells(1, sColumnLetter).Column
End Function

'FYI, the opposite way...
Function ColumnLetter(ColumnNum As Integer) As String
ColumnLetter = Split(Cells(1, ColumnNum).Address, "$")(1)
End Function

Thanks Kenneth. Also point to note is that I wish to have all vba coding to be done in the same worksheet. Thank you.

Kenneth Hobs
11-02-2016, 05:32 AM
Sub Main2()
Dim a() As Variant, v As Variant, r As Range, rr As Range, c As Range
Dim i As Long, ws As Worksheet, s As String
Dim aa() As String, bb() As String, ii As Long

Set ws = ActiveSheet

'Get unique values in column A of ws.
Set r = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
a() = WorksheetFunction.Transpose(r)
a() = UniqueArrayByDict(a())
'MsgBox Join(a, vbLf)

Set r = ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)) 'ws's Row 1 column cells
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = "ReMastered Data"
'Copy row 1 column values.
r.Copy .Range("A1")

'Fill ReMasetered Data from ws.
For i = LBound(a) To UBound(a)
Set r = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
ws.UsedRange.AutoFilter 1, a(i)
Set c = StripFirstRow(ws.UsedRange.Cells.SpecialCells(xlCellTypeVisible))
Set r = r.Resize(c.Rows.Count, c.Columns.Count)
c.Copy r

'Copy and format 2nd block from ws.
Set r = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
Set r = r.Resize(c.Rows.Count, c.Columns.Count)
c.Copy r
r.Interior.Color = 14277081

'Change values of Remastered Data's Column B, 2nd block, to negative
For Each c In Intersect(r, r.Columns("B"))
c.Value = c.Value * -1
'Change prefix of Column A from number to number of suffix in Column C: A=1, B-2, etc.
ii = c.Row
aa() = Split(c.Offset(, 1).Value2, " ")
s = Cells(1, aa(UBound(aa))).Column 'Letter to number...
bb() = Split(c.Offset(, -1).Value2, "-")
bb(0) = s
c.Offset(, -1).Value2 = Join(bb, "-")
Next c
Next i

'Autofit ReMastered Data columns
.UsedRange.Columns.EntireColumn.AutoFit
End With

'Clear autofilter
ws.UsedRange.AutoFilter
End Sub