Copy & Pasting in VBA

[Anthon]

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]

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]

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]

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]

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]

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