Excel VBA Cell copy / paste Code request

**RxMiller** · 08-17-2011, 04:40 PM

The following code starts in column B. It bolds the first value of a row and changes the font to a lighter shade/tint if it is repeated on the following row.

Question: for the bold rows, the value in the 4th column needs to be copied on the same row in column 33.

Efficiency counts. This report can have 35,000 rows.

ObjXL.Range("B" & intRowPos & ":B" & intMaxRecordCount + (intRowPos)).Select
For Each c In ObjXL.ActiveWindow.Selection
    If c.Value <> c.Offset(-1, 0).Value Then
        c.Font.FontStyle = "Bold"
                c.Resize(, 6).Font.Bold = True 
' goal: Copy value in 4th column and past it in column 33  
 Else
        c.Font.ThemeColor = xlThemeColorDark1
        c.Font.TintAndShade = -0.249977111
        c.Resize(, 5).Font.ThemeColor = xlThemeColorDark1
        c.Resize(, 5).Font.TintAndShade = -0.249977111 
         c.Resize(, 6).Font.Bold = True         
    End If
Next c
    Set c = Nothing

This code is running from inside MS Access
ObjXL is an object varable for Excel.Application

**davegugg** · 08-17-2011, 04:56 PM

This should run much more efficiently. I couldn't test so there could be small errors, but it should be solid overall. Let me know if you need help with any errors you may encounter.

With objXL.ActiveWorkbook.ActiveSheet
    For i = intRowPos To intMaxRecordCount + intRowPos
        If .Cells(i, "B").Value <> .Cells(i - 1, "B").Value Then
            .Range(.Cells(i, "B"), .Cells(i, "H")).Font.FontStyle = "Bold"
            .Cells(i, 33).Value = .Cells(i, 4).Value
        Else
            .Range(.Cells(i, "B"), .Cells(i, "G")).Font.ThemeColor = xlThemeColorDark1
            .Range(.Cells(i, "B"), .Cells(i, "G")).TintAndShade = -0.249977111
            .Range(.Cells(i, "B"), .Cells(i, "H")).Font.Bold = True
        End If
    Next i
End With

**RxMiller** · 08-17-2011, 06:03 PM

This is great! Have an error and isolated it in debug mode (with objxl.visible = true)
Found it, my apologies if you looked as I re-pasted:

One more thing: I need to clear the value in column AD in the Else statement

With ObjXL.ActiveWorkbook.ActiveSheet
    'objxl.ActiveWorkbook.ActiveSheet
    For i = intRowPos To intMaxRecordCount + intRowPos
        If .Cells(i, "B").Value <> .Cells(i - 1, "B").Value Then
            .Range(.Cells(i, "B"), .Cells(i, "H")).Font.FontStyle = "Bold"
            .Cells(i, 33).Value = .Cells(i, 4).Value
        Else
            .Range(.Cells(i, "B"), .Cells(i, "G")).Font.ThemeColor = xlThemeColorDark1
            .Range(.Cells(i, "B"), .Cells(i, "G")).Font.TintAndShade = -0.249977111
            '.Range(.Cells(i, "B"), .Cells(i, "H")).Font.Bold = True      <<<-----   need to clear the value in  column AD
        End If
    Next i
End With