I have an excel macro that keeps coming up with the error message that it is out of cells. I am wondering if there is anything I can do?

Sure, let's take a look. A macro that runs down to the bottom of the sheet needs to be written in a way that it can pickup again on another sheet or another column else it will bomb out.

Click GO ADVANCED and use the paperclip icon to post up your workbook.

Or post your code... or both.

Well its working on pasted data so if that varies the macro varies.

The user pastes data onto one spreadsheet it then creates a new spreadsheet that organizes this data into a readable form.

Well... ok. Let's take a look.

Okay here it is.. The ByRoom is the macro and the BEFORE is how the data should be set up.

I did this macro a while back but they came back saying when there are 250 rooms they have the out of cells issue.

Ok, after 250 rooms you're out of columns. What do you want to happen?

Here, I rewrote the macro to take out all the "selecting". You probably learned that from using the macro recorder, but selecting should almost always be edited out. The resulting code is extremely fast in comparison.

On the same sheet attached, I made a list of 500 rooms. The macro will create sequential sheets... it ran 500 rooms in about 10 seconds.


Option Explicit

Sub ByRm()
Dim Col As Long, Cnt As Long, LR As Long
Dim cFind As Range, Suites As Range, Rm As Range
Dim RmSht As Worksheet, listSht As Worksheet, FFESht As Worksheet
On Error GoTo ErrorHandler
Application.ScreenUpdating = False

If MsgBox("Make sure you have already formatted the Matrix." & vbCrLf & "Are you sorting by Rm?", vbQuestion + vbYesNo, "Matrix Tool?") = vbNo Then Exit Sub

'Setup
Set listSht = Sheets("Sheet1")
Set FFESht = Sheets("FFE_Item_Matrix")
LR = listSht.Range("C" & Rows.Count).End(xlUp).Row
Set Suites = listSht.Range("C2:C" & LR)
Col = 256
listSht.Range("A:C").Sort Key1:=listSht.Range("B1"), Order1:=xlAscending, Header:=xlYes

For Each Rm In Suites
If Col > 250 Then 'add a new sheet if needed
Cnt = Cnt + 1
Sheets.Add(After:=Worksheets(Sheets.Count)).Name = "Rooms" & Cnt
Set RmSht = ActiveSheet
FFESht.Columns("A:F").Copy RmSht.Range("A1")
Col = 7
FFESht.Activate
End If

Set cFind = FFESht.Range("G2:DD2").Find(What:=Rm.Text, After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If cFind Is Nothing Then
MsgBox "Item Not Found at " & Rm.Offset(0, -1)
GoTo ErrorExit
End If

cFind.EntireColumn.Copy RmSht.Cells(1, Col)
RmSht.Cells(3, Col) = Rm.Offset(0, -1)
Col = Col + 1
Next Rm
Sheets(Sheets.Count).Activate

ErrorExit:
Set Suites = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
Resume Next
End Sub

Note, the .FIND acts weird occasionally. If it seems to error out at the very beginning, delete the sheet it added and manually run a CTRL-F find for "1BW". After that, it seems to remember itself and work fine.

Thanks that worked!

Do you know why find doesn't deal with numbers only? (if room type is only numbers)

Is that what's going on? Maybe a different approach than FIND would be better...

Here, this version uses a standard MATCH() to find the Suite Type... it should work regardless of the data type.

Option Explicit

Sub ByRm()
Dim Col As Long, Cnt As Long, LR As Long, ColFnd As Long
Dim Suites As Range, Rm As Range
Dim RmSht As Worksheet, listSht As Worksheet, FFESht As Worksheet
On Error Resume Next
Application.ScreenUpdating = False

If MsgBox("Make sure you have already formatted the Matrix." & vbCrLf & "Are you sorting by Rm?", vbQuestion + vbYesNo, "Matrix Tool?") = vbNo Then Exit Sub

'Setup
Set listSht = Sheets("Sheet1")
Set FFESht = Sheets("FFE_Item_Matrix")
LR = listSht.Range("C" & Rows.Count).End(xlUp).Row
Set Suites = listSht.Range("C2:C" & LR)
Col = 256
listSht.Range("A:C").Sort Key1:=listSht.Range("B1"), Order1:=xlAscending, Header:=xlYes

For Each Rm In Suites
If Col > 250 Then 'add a new sheet if needed
Cnt = Cnt + 1
Sheets.Add(After:=Worksheets(Sheets.Count)).Name = "Rooms" & Cnt
Set RmSht = ActiveSheet
FFESht.Columns("A:F").Copy RmSht.Range("A1")
Col = 7
FFESht.Activate
End If

ColFnd = Application.WorksheetFunction.Match(Rm.Text, FFESht.Range("A2:EE2"), False)
If ColFnd = 0 Then
MsgBox "Item Not Found at " & Rm.Offset(0, -1)
GoTo ErrorExit
End If

FFESht.Cells(1, ColFnd).EntireColumn.Copy RmSht.Cells(1, Col)
RmSht.Cells(3, Col) = Rm.Offset(0, -1)
ColFnd = 0
Col = Col + 1
Next Rm
Sheets(Sheets.Count).Activate

ErrorExit:
Set Suites = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub