Excel - A macro to create new workbook and copy data

yes trowa..

Please help me Trowa

Hi Trowa,

Thanks for the code, this is working fine but the output is thrown in the same sheet, I need output in different sheets, like shridhar1 would be one workbook, shridhar2 would be another workbook.

Thanks in advance.

Regards,
Shridhar

Hi Shridhar,

This is what I did:
Created 2 workbooks.
1 being Source and 1 being Destination.

Source has headers in A1:D1.
Destination has headers in B1:E1 (same as source) and in A2:A6 (the colors)

When you run the code below from a module in Source book, the code will check if destination book is open. If not then book is opened and the counted colors are entered.

To make things work, make sure you create and save your destination book with the same setup as me (meaning Headers in same place).
Look for the green text in the code. There are 3 of them. 1 to change Source name, 1 to change Destination name and 1 for the full path of the destination book (for when it's closed).

NOTE: only the first 4 columns of the source book will be checked as per your instruction.

NOTE 2: code will loop through ALL cells of 4 columns. That will take some time. If you think it takes to long the look for the following line in the code:
For Each cell In Range(Cells(1, ColNr), Cells(Rows.Count, ColNr))
Now change Rows.Count into the number of rows you want to check (If you only colored the first 100 rows then replace with 100).

Here is the code:

Sub CountColors()
Dim RedColor, GreenColor, BlueColor, PurpleColor, OrangeColor, ColNr As Integer
Dim RedCount, GreenCount, BlueCount, PurpleCount, OrangeCount As Long

Application.ScreenUpdating = False

RedColor = 3
GreenColor = 43
BlueColor = 23
PurpleColor = 47
OrangeColor = 44

Do
    ColNr = ColNr + 1
    Workbooks("Source.xls").Activate 'Change filename
    For Each cell In Range(Cells(1, ColNr), Cells(Rows.Count, ColNr))
        If cell.Interior.ColorIndex = RedColor Then RedCount = RedCount + 1
        If cell.Interior.ColorIndex = GreenColor Then GreenCount = GreenCount + 1
        If cell.Interior.ColorIndex = BlueColor Then BlueCount = BlueCount + 1
        If cell.Interior.ColorIndex = PurpleColor Then PurpleCount = PurpleCount + 1
        If cell.Interior.ColorIndex = OrangeColor Then OrangeCount = OrangeCount + 1
    Next cell
    
    On Error GoTo OpenBook
    Workbooks("Destination").Activate 'Change filename
Cont:
    Cells(2, ColNr + 1) = RedCount
    Cells(3, ColNr + 1) = GreenCount
    Cells(4, ColNr + 1) = BlueCount
    Cells(5, ColNr + 1) = PurpleCount
    Cells(6, ColNr + 1) = OrangeCount

    RedCount = 0
    GreenCount = 0
    BlueCount = 0
    PurpleCount = 0
    OrangeCount = 0
        
Loop Until ColNr = 4

Application.ScreenUpdating = True

Exit Sub
OpenBook:
'Change path to match yours
Workbooks.Open "C:\MyDocuments\Destination.xls"
GoTo Cont
End Sub

Best regards,
Trowa

So you already created and formatted a new workbook for that.

Any specific location in mind ( as in which sheet, which cell)?

Paste entire sentence in a cell or spread across multiple cells?
Paste all 5 sentences in a cell or spread across multiple rows?

Do you want to overwrite old color report when new report is created?
or place new below old (or vice versa)?
or place new next to old (or vice versa)?

Do you want to loop through all columns with data in the 1st row (or whatever row, to know which columns are being used. Could be fixed numbers of columns as well), to create all color reports at once?

Do you want to loop through sheets as well?

Let me know.

Best regards,
Trowa

Hi Shridhar,

Sorry to let you wait, but here is the requested code.

After running the code, excel will fire four input boxes your way that will let you enter your column letters. You can enter the column letters in any order you like (Meaning alphabetical order isn't necessary).

The code will also loop through each sheet in the source workbook.

Here is the code:

Sub CountColors()
Dim RedColor, GreenColor, BlueColor, PurpleColor, OrangeColor, x, y As Integer
Dim RedCount, GreenCount, BlueCount, PurpleCount, OrangeCount As Long
Dim myCol, myCol1, myCol2, myCol3, myCol4 As String
Dim ws As Worksheet

Application.ScreenUpdating = False

RedColor = 3
GreenColor = 43
BlueColor = 23
PurpleColor = 47
OrangeColor = 44

myCol1 = InputBox("Enter column letter of the first column to count colors:", "Input column letter")
myCol2 = InputBox("Enter column letter of the second column to count colors:", "Input column letter")
myCol3 = InputBox("Enter column letter of the third column to count colors:", "Input column letter")
myCol4 = InputBox("Enter column letter of the fourth column to count colors:", "Input column letter")

x = 1

Do
    Workbooks("Source.xls").Activate 'Change filename
    y = y + 1
    If y = 1 Then myCol = myCol1
    If y = 2 Then myCol = myCol2
    If y = 3 Then myCol = myCol3
    If y = 4 Then myCol = myCol4
    
    For Each ws In Worksheets
        For Each cell In Range(Cells(1, myCol), Cells(20, myCol))
            If cell.Interior.ColorIndex = RedColor Then RedCount = RedCount + 1
            If cell.Interior.ColorIndex = GreenColor Then GreenCount = GreenCount + 1
            If cell.Interior.ColorIndex = BlueColor Then BlueCount = BlueCount + 1
            If cell.Interior.ColorIndex = PurpleColor Then PurpleCount = PurpleCount + 1
            If cell.Interior.ColorIndex = OrangeColor Then OrangeCount = OrangeCount + 1
        Next cell
    Next ws
    
    On Error GoTo OpenBook
    Workbooks("Destination.xls").Activate 'Change filename
Cont:
    x = x + 1
    Cells(2, x) = RedCount
    Cells(3, x) = GreenCount
    Cells(4, x) = BlueCount
    Cells(5, x) = PurpleCount
    Cells(6, x) = OrangeCount
    
    RedCount = 0
    GreenCount = 0
    BlueCount = 0
    PurpleCount = 0
    OrangeCount = 0
    
Loop Until y = 4

Application.ScreenUpdating = True

Exit Sub
OpenBook:
'Change path to match yours
Workbooks.Open "C:\MyDocuments\Destination.xls"
GoTo Cont
End Sub

Best regards,
Trowa

Hi Shridhar,

You are absolutely right.
The code stayed on the same sheet and multiplied the counted colors by the number of sheets you have.

My test data was rather poor (3 sheets of the same setup).

To solve this, find the code line:
For Each ws In Worksheets

And place the following line below it:
ws.Activate

Best regards,
Trowa

Hi Shelb,

How about asking the user for the sheet name like:

Sub RunMe()
Dim SheetName As String

SheetName = InputBox("Please enter sheet name:", "Creating a new sheet")
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = SheetName

End Sub

Best regards,
Trowa

Good day,

I understand this thread is already closed, but I'm just curios if it would be possible to have a full copy of the whole sheet, into a new XLS file.

Let's say from column "A" until the last column, the same as for the rows.
Can you guys help me with a code like this one?

Thanks and much appreciated.
-Giomar

Hi Giomar,

When you right-click your sheets tab, there is an option to move or copy the entire sheet. Selecting that, will give you the option to select the workbook and after which sheet you would like to move or copy the sheet to.

Best regards,
Trowa