Results 1 to 7 of 7
  1. #1
    Platinum Lounger
    Join Date
    Feb 2002
    Location
    A Magic Forest in Deepest, Darkest Kent
    Posts
    5,681
    Thanks
    0
    Thanked 1 Time in 1 Post

    Copy if the font colour is black (97 onwards)

    I have written a little application which results in a set of figures being placed in the columns A to C.

    What I would like to do is have a piece of code that runs through the cells A1:C1 to Ax:Cx picking up any cells whose font colour is black, copy the values in the 3 cells and append these values to (ultimately)an email.

    I have written the following but it only copies the value of the value in the last A cell to cell A1 in sheet2!!!! I want the whole lot appended after each record, can you help please?

    Private Sub cmdSendMac_Click()
    Dim RowCount As Integer
    Dim Choice As Integer
    RowCount = Range("A1").End(xlDown).Row

    Range("A1:C1").Select
    For Choice = 1 To RowCount

    ActiveCell.Offset(1, 0).Select

    If ActiveCell.Font.Color = RGB(0, 0, 0) And ActiveCell.Value <> "" Then

    ActiveCell.Copy Destination:=Worksheets("Sheet2").Range("A1:C1")

    Else

    End If

    Next Choice


    End Sub

    Thanks in advance

    Jerry
    Jerry

  2. #2
    Platinum Lounger
    Join Date
    Feb 2002
    Location
    A Magic Forest in Deepest, Darkest Kent
    Posts
    5,681
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Copy if the font colour is black (97 onwards)

    Ok Guys, I have sorted it but it is very, very dirty using the activecell.offset method

    As I say it is dirty but if you have any suggestions I would be grateful. Anyway here it is....gulp!


    Private Sub cmdSendMac_Click()
    Dim RowCount As Integer
    Dim Choice As Integer
    Dim Col1 As String
    Dim Col2 As String
    Dim Col3 As String

    RowCount = Range("A1").End(xlDown).Row

    Range("A1").Select

    For Choice = 1 To RowCount

    ActiveCell.Offset(1, 0).Select

    If ActiveCell.Font.Color = RGB(0, 0, 0) Then

    Col1 = ActiveCell.Value

    ActiveCell.Offset(0, 1).Select

    Col2 = ActiveCell.Value

    ActiveCell.Offset(0, 1).Select

    Col3 = ActiveCell.Value

    ActiveCell.Offset(0, -2).Select

    Worksheets("Sheet2").Select
    Range("A1").Select

    While ActiveCell.Value <> ""
    ActiveCell.Offset(1, 0).Select

    Wend

    ActiveCell.Value = Col1

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Value = Col2

    ActiveCell.Offset(0, 1).Select

    ActiveCell.Value = Col3

    Worksheets("Sheet1").Select

    Range("A1").Select

    While ActiveCell <> Col1

    ActiveCell.Offset(1, 0).Select
    Wend


    Else

    End If

    Next Choice


    End Sub
    Jerry

  3. #3
    2 Star Lounger
    Join Date
    Sep 2003
    Location
    Louisville, Kentucky, USA
    Posts
    134
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Copy if the font colour is black (97 onwards)

    I think you're not just copying the last occurrence into sheet2!a1.c1, but actually copying all occurences. So naturally you only see the last one.

    I haven't tested this but I think you can just modify your original code as follows:

    Private Sub cmdSendMac_Click()
    Dim RowCount As Integer
    Dim Choice As Integer
    Dim i As Integer
    RowCount = Range("A1").End(xlDown).Row

    Range("A1:C1").Select
    i=0
    For Choice = 1 To RowCount

    ActiveCell.Offset(1, 0).Select

    If ActiveCell.Font.Color = RGB(0, 0, 0) And ActiveCell.Value <> "" Then
    i=i+1
    ActiveCell.Copy Destination:=Worksheets("Sheet2").Range("A"+i+":C"+i)

    Else

    End If

    Next Choice


    End Sub

  4. #4
    Platinum Lounger
    Join Date
    Feb 2002
    Location
    A Magic Forest in Deepest, Darkest Kent
    Posts
    5,681
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Copy if the font colour is black (97 onwards)

    Thanks Chipshot

    I had a go with your code but it hung on:

    ActiveCell.Copy Destination:=Worksheets("Sheet2").Range("A"+i+":C" +i)

    I think I will stick with my "dirty" option as it seems to work OK but thank you very much for your time and effort

    Jerry
    Jerry

  5. #5
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Copy if the font colour is black (97 onwards)

    If you need to work with colors in the future, take a look at Functions For Working With Cell Colors on Chip Pearson's website.

  6. #6
    Platinum Lounger
    Join Date
    Feb 2002
    Location
    A Magic Forest in Deepest, Darkest Kent
    Posts
    5,681
    Thanks
    0
    Thanked 1 Time in 1 Post

    Re: Copy if the font colour is black (97 onwards)

    <img src=/S/cheers.gif border=0 alt=cheers width=30 height=16>
    Jerry

  7. #7
    2 Star Lounger
    Join Date
    Sep 2003
    Location
    Louisville, Kentucky, USA
    Posts
    134
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Copy if the font colour is black (97 onwards)

    You might try Range("A"+format(i,"#")+":C"+format(i,"#"))

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •