I have some code that loops through a row and a column and compares data. When it finds the values being equal it copies the columns the row is in and pastes it on another sheet along with the previous value of the column.

For Each CCell In Range("C2:C65418")
If Not IsEmpty(CCell.Value) Then
Dim room As String
CCell.Offset(0, -1).Select
room = Selection.Value
Sheets("FFE_Item_Matrix").Select
For Each GCell In Range("G2:ZZ2")
If Not IsEmpty(GCell.Value) Then
If CCell <> GCell Then
'THIS IS NOT WORKING:
Sheets("Rooms").Select
Range("G2").Activate
Range("G2").Select
Selection.Value = GCell.EntireColumn
End If
Else
Exit For
End If
Next GCell
Else
Exit For
End If
Next CCell

I'm having trouble copying the column the row is in. Can someone help me? Its not working.

It would be easiest to assist if I could see a before/after sort of sample sheet. It would make fixing your macro simpler, or possibly point to a solution that doesn't include individually looping through 65000 cells. (ugh).

If you click on GO ADVANCED you can use the paperclip icon to post up a sample worksheet. It would be great to see a "desired results" page so the goal is clear.

Just staring at it with no sheet to test on or understanding of even where you were when you activated this macro, this seems to me be what you're aiming for, or at least closer to it:

Code:

---

    For Each CCell In Range("C2:C65418")
        If Not IsEmpty(CCell.Value) Then
            room = CCell.Offset(0, -1).Value
            Sheets("FFE_Item_Matrix").Activate
           
                For Each GCell In Range("G2:ZZ2")
                    If Not IsEmpty(GCell.Value) Then
                        If CCell <> GCell Then
                            GCell.EntireColumn.Copy
                            Sheets("Rooms").Range("G:G").PasteSpecial Paste:=xlPasteAll, _
                                Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
                        End If
                    Else
                        Exit For
                    End If
                Next GCell
        Else
            Exit For
        End If
    Next CCell

---

Well it doesn't loop through all the cells individually. It stops as soon as it finds a blank one.

There's the sample... So on sheet2 it goes down the B row and compares those values to the 2nd column on sheet1.

It stores the values on sheet 2, column 1 for when it finds a match. (in the outer loop that's what the room variable is for)

So then when it finds a match it should copy the sheet1 column where it found the match and paste to a new sheet.

Code:

---

For Each CCell In Range("C2:C65418")
        If Not IsEmpty(CCell.Value) Then
        Dim room As String
        CCell.Offset(0, -1).Select
        room = Selection.Value
        Sheets("FFE_Item_Matrix").Select
'WORKS FINE TO HERE
        For Each GCell In Range("G2:ZZ2")
            If Not IsEmpty(GCell.Value) Then
                If CCell <> GCell Then
                    Sheets("Rooms").Select
                    Range("G2").Activate
                    Range("G2").Select
                    Selection.Value = GCell.EntireColumn
                End If
            Else
                Exit For
            End If
        Next GCell
        Else
            Exit For
        End If
    Next CCell

---

if you have a better solution please let me know!

Also for this new sheet if you know how to make it so that each time it pastes a column it moves over one that would be great. At the moment for testing I had it just post in the G column but I need it to do that for the first, H for the second, etc, etc until all the rows in Sheet2 have gone through.

Again, no sheet means helping blind. I've demonstrated how to ADD a column to an existing column, all the cells add together:

Code:

---

GCell.EntireColumn.Copy
Sheets("Rooms").Range("G:G").PasteSpecial Paste:=xlPasteAll, _
    Operation:=xlAdd, SkipBlanks:=False, Transpose:=False

---

If what you want now is to paste the column into the first empty column, then something like this:

Code:

---

GCell.EntireColumn.Copy Sheets("Rooms").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

---

There's the sample... So on sheet2 it goes down the B row and compares those values to the 2nd column on sheet1.

It stores the values on sheet 2, column 1 for when it finds a match. (in the outer loop that's what the room variable is for)

So then when it finds a match it should copy the sheet1 column where it found the match and paste to a new sheet (sheet 3). The column on sheet3 should shift one each time a column is copied.

Quote:

---

Originally Posted by adalton

So then when it finds a match it should copy the sheet1 column where it found the match and paste to a new sheet (sheet 3). The column on sheet3 should shift one each time a column is copied.

---

Since the dataset is so small and the explanation not 100% clear in my head, how about posting this sample workbook with the desired/expected results, too? Let me see exactly what you want created.

Here.. Result shows what I want
BEFORE sheet is what it looks like first. It has room types and what's in the room. It compares it to the COMPARE sheet which has room numbers and types. The result shows the room number type and what's in the room.

So it compares the types, then when it finds a match copies the column to the RESULT sheet so you can see the room number, type and what's in it.

I want to know how to make it move over one column each time it pastes the column in. Also is it possible to sort a row (should go in order of ascending room)?

Here is the whole code:

Code:

---


Sub ByRoom()
'
' ByRoom Macro
'

'
    On Error GoTo ErrorHandler
   
If MsgBox("Make sure you have already formatted the Matrix." & vbCrLf & "Are you sorting by room?", vbQuestion + vbYesNo, "Matrix Tool?") = vbYes Then
    Sheets.Add.Name = "Rooms"
    Sheets("FFE_Item_Matrix").Select
    Columns("A:F").Select
    Range("F1").Activate
    Selection.Copy
    Sheets("Rooms").Select
    Range("A1").Select
    ActiveSheet.Paste
   
    Worksheets("Sheet1").Select
    Columns("C:C").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:C65418")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For Each CCell In Range("C2:C65418")
        If Not IsEmpty(CCell.Value) Then
        Dim room As String
        CCell.Offset(0, -1).Select
        room = Selection.Value
        Sheets("FFE_Item_Matrix").Select
        For Each GCell In Range("G2:ZZ2")
            If Not IsEmpty(GCell.Value) Then
                If CCell <> GCell Then
                    GCell.EntireColumn.Copy
                    Sheets("Rooms").Range("G:G").PasteSpecial Paste:=xlPasteAll, _
                        Transpose:=False

                End If
            Else
                Exit For
            End If
        Next GCell
        Else
            Exit For
        End If
    Next CCell
       
   
Else
    Exit Sub
End If
    Exit Sub
ErrorHandler:
    Resume Next
End Sub

---

When I do this its still copying the first part over (Columns A-F done outside the loop)

After looking at the macro and the suggested line of code I already gave you in post #6, that is still the right answer as far as I can see.

Code:

---

GCell.EntireColumn.Copy Sheets("Rooms").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

---

Put that in place in these lines:

Code:

---

        For Each GCell In Range("G2:ZZ2")
            If Not IsEmpty(GCell.Value) Then
                If CCell <> GCell Then
                    GCell.EntireColumn.Copy Sheets("Rooms").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
                End If

---

SHort of designing an entirely new macro matrix, I know of no way to sort across a row.

This copies the first part (the A:F) and pastes it in the empty cells. It only does it once then continually pastes over it.

Code:

---



Sub ByRoom()
'
' ByRoom Macro
'

'
    On Error GoTo ErrorHandler
   
If MsgBox("Make sure you have already formatted the Matrix." & vbCrLf & "Are you sorting by room?", vbQuestion + vbYesNo, "Matrix Tool?") = vbYes Then
    Sheets.Add.Name = "Rooms"
    Sheets("FFE_Item_Matrix").Select
    Columns("A:F").Select
    Selection.Copy
    Sheets("Rooms").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("G1").Activate
    Sheets("FFE_Item_Matrix").Select
    Range("G1").Activate
   
    Worksheets("Sheet1").Select
    Columns("C:C").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:C65418")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For Each CCell In Range("C2:C65418")
        If Not IsEmpty(CCell.Value) Then
        Dim room As String
        CCell.Offset(0, -1).Select
        room = Selection.Value
        Sheets("FFE_Item_Matrix").Select
        For Each GCell In Range("G2:ZZ2")
            If Not IsEmpty(GCell.Value) Then
                If CCell <> GCell Then
                    GCell.Activate
                    GCell.EntireColumn.Copy Sheets("Rooms").Select.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
                    ActiveSheet.Paste
                End If
            Else
                Exit For
            End If
        Next GCell
        Else
            Exit For
        End If
    Next CCell
       
   
Else
    Exit Sub
End If
    Exit Sub
ErrorHandler:
    Resume Next
End Sub

---

Thanks for your help so far.. sorry to be such a bother!

I think that "activesheet.paste" after the line of code I gave you is unnecessarily copying a second time, try removing that and see if you get better results.

Thank you. You have been a HUGE help.