	[x] Posted via EE Mobile
	Search, ask, and monitor your questions on the go with EE Mobile. Visit Experts Exchange from your mobile device and never be out of touch again.

Question

	[x] Attachment Details

[x]

The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

The Grade of the Solution
The Zone Rank of the Expert Providing the Solution
The Number of Author and Expert Comments
The Number of Experts Contributing
The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!

7.7

Move rows as per BO. Need to record them in comments.

Asked by bsharath in Microsoft Excel Spreadsheet Software, Microsoft Applications, Microsoft Office Suite

Tags: Excel, Macro

Hi,

Move rows as per BO. Need to record them in comments.
At present when i move a colum Q cell from on to another the seat details gets recorded in the cell B & T
Cell T will have the details on from which seat to which it has been moved.

Can the same happen even when this below macro does the Mass movement.

Need the comments to be created or insert the data into the existing comments as the same as it does now when swapped.

By this even the Temp moved data to the end needs to have in colum B

REgards
Sharath

View the Solution FREE for 30 Days

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:

           
           
             Public DupeFound As Boolean
Public NoMatch As Boolean
Public FreeSeats As Long
 
 
Sub aMatch_B_and_BO()
Dim rMany As Range
Dim rOnce As Range
Dim PermMaxRow As Long
Dim VarMaxRow As Long
Dim cnter As Long
 
Sheets("Desktops").Select
 
 
ChkForDupes 'Checks for duplicates in column BO..there cannot be any
If DupeFound = True Then Exit Sub
 
ChkForMatch 'Checks to make sure every entry in column BO has a match in column B
If NoMatch = True Then Exit Sub
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
 
PermMaxRow = Range("B" & Cells.Rows.Count).End(xlUp).Row 'Last row with value in column B (
VarMaxRow = Range("BO" & Cells.Rows.Count).End(xlUp).Row 'Last row with a value in BO
 
CreateLastRow 'Creates an end row to use for the end of the data
 
Set rOnce = Range("B3")
Set rMany = Range("BO2")
        If rMany.Offset(1, 0).Value <> "" Then
            Set rMany = rMany.Offset(1, 0) 'move column B range variable down 1 row
        Else
            Set rMany = rMany.End(xlDown)
        End If
    
 
 
NextB_row:
Do Until rOnce.Row > PermMaxRow
    Do Until UCase(rMany.Value) = UCase(rOnce.Value) 'Search for B's value in BO
        
        'Move BO range variable to next cell with value in BO
        If rMany.Offset(1, 0).Value <> "" Then
            Set rMany = rMany.Offset(1, 0)
        Else
            Set rMany = rMany.End(xlDown)
        End If
        
        'If rMany.Row > VarMaxRow Then value in B was not found in BO
        'so move B row variable down 1, move BO back to top, and start again
        If rMany.Row > VarMaxRow Or rOnce.Value = "" Then
            
            'move column B range variable down 1 row
            Set rOnce = rOnce.Offset(1, 0)
            
            'Move BO range variable back to first cell with value in BO
            Set rMany = Range("BO2")
                If rMany.Offset(1, 0).Value <> "" Then
                    Set rMany = rMany.Offset(1, 0)
                Else
                    Set rMany = rMany.End(xlDown)
                End If
            GoTo NextB_row
            Exit Do
        End If
    Loop
 
 
'If value in B was found in BO
 
'If value found if BO is already the same row as the value in B
'then do nothing...just move range variables and start over with loop
If rMany.Row = rOnce.Row Then
    GoTo nxt2
End If
 
        
        'Column E, O, Q, and BO are used to determine if a seat is occupied
        ' If no value in new location  then Copy BO row to new location in B row
        'and color B row yellow
        If Cells(rOnce.Row, "E").Value = "" And Cells(rOnce.Row, "O").Value = "" And Cells(rOnce.Row, "Q").Value = "" And Cells(rOnce.Row, "BO").Value = "" Then
            Range(Cells(rMany.Row, "E"), Cells(rMany.Row, "CE")).Copy Cells(rOnce.Row, "E") ' Do the copy
            Range(Cells(rOnce.Row, "F"), Cells(rOnce.Row, "Q")).Interior.ColorIndex = 6
            Range(Cells(rMany.Row, "E"), Cells(rMany.Row, "CE")).ClearContents 'Clear the old location
                
                'If the row that was found was a temp row, then delete it
                If Cells(rMany.Row, "D").Value = "Temp" Then
                    Set rMany = rMany.Offset(1, 0)
                    rMany.Offset(-1, 0).EntireRow.Delete
                End If
                
            VarMaxRow = Range("BO" & Cells.Rows.Count).End(xlUp).Row 'Reset Last used BO row
        
        ' If there is already a value in new location then Copy B row to end of data
        'Then move BO row into B row
        Else
            'Move B row to end of data
            Range(Cells(rOnce.Row, "E"), Cells(rOnce.Row, "CE")).Copy Cells(Range("D" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row, "E")
            'Put word temp in column D where B row was just moved to (the end of data)
            Cells(Range("D" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Row, "D").Value = "Temp"
            
            'Move BO row to where B row data was and color B row yellow
            Range(Cells(rMany.Row, "E"), Cells(rMany.Row, "CE")).Copy Cells(rOnce.Row, "E")
            Range(Cells(rOnce.Row, "F"), Cells(rOnce.Row, "Q")).Interior.ColorIndex = 6
             
            'Clear the old location
            Range(Cells(rMany.Row, "E"), Cells(rMany.Row, "CE")).ClearContents
            
                'If the row that was found was a temp row, then delete it
                If Cells(rMany.Row, "D").Value = "Temp" Then
                    Set rMany = rMany.Offset(1, 0)
                    rMany.Offset(-1, 0).EntireRow.Delete
                End If
            
            
            'Reset last used row in BO in case B row that was just moved to end of data had a value in BO
            VarMaxRow = Range("BO" & Cells.Rows.Count).End(xlUp).Row
        End If
nxt2:
            Set rOnce = rOnce.Offset(1, 0) 'move column B range variable down 1 row
            
            'Move BO range variable back to first cell with value in BO
            Set rMany = Range("BO2")
                If rMany.Offset(1, 0).Value <> "" Then
                    Set rMany = rMany.Offset(1, 0)
                Else
                    Set rMany = rMany.End(xlDown)
                End If
    
 
Loop
Selection.EntireRow.Delete xlUp 'Deletes asterik row (temporary last row)
 
 
'Count temp rows
Set rMany = Selection.Offset(0, 3)
Do Until rMany.Value = ""
    Set rMany = rMany.Offset(1, 0)
    cnter = cnter + 1
Loop
'Selection.Offset(4, 0).Select
 
 
'Enter "Free Seat" in column P and "Chennai" in column AV
'if columns E, O, and Q are blank (a free seat)
FindFreeSeats
 
 
ActiveWindow.ScrollRow = Selection.Row
ActiveWindow.ScrollColumn = 1
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
 
MsgBox "Finished!" & vbNewLine & cnter & " rows had to be moved to make way for new data and did not have a match to put them back" & _
 vbNewLine & "There are " & FreeSeats & " free seats"
 
End Sub
Private Sub ChkForMatch()
Dim rOnce As Range
Dim rMany As Range
Dim MaxOnceRow As Long
Dim MaxManyRow As Long
NoMatch = False
 
Set rOnce = Range("BO3")
MaxOnceRow = Range("BO" & Cells.Rows.Count).End(xlUp).Row
 
Set rMany = Range("B3")
MaxManyRow = Range("B" & Cells.Rows.Count).End(xlUp).Row
 
nxt:
    Do
        If rOnce.Row > MaxOnceRow Then Exit Sub
        If UCase(rMany.Value) = UCase(rOnce.Value) Or rOnce.Value = "" Then
            Set rMany = Range("B3")
            If rOnce.Offset(1, 0) <> "" Then
                Set rOnce = rOnce.Offset(1, 0)
            Else
                Set rOnce = rOnce.End(xlDown)
            End If
            GoTo nxt
            Exit Do
        End If
        Set rMany = rMany.Offset(1, 0)
        If rMany.Row > MaxManyRow Then
            GoTo NotFound
        End If
    Loop
 
 
 
Exit Sub
NotFound:
    NoMatch = True
    rOnce.Select
    ActiveWindow.ScrollRow = Selection.Row
    ActiveWindow.ScrollColumn = Range("BO1").Column
    rOnce.Select
    MsgBox rOnce.Value & " in " & rOnce.Address(False, False) & " was not found in column B"
    
 
End Sub
 
Private Sub CreateLastRow()
'Finds the last row with anything at all and creates
'a row underneath it filled with asteriks to use for the last row
Dim r As Range
Dim cnter As Integer
 
 
Set r = Cells(4000, Cells.Columns.Count)
nxt:
    Set r = r.Offset(-1, 0)
    If r.End(xlToLeft).Column = 1 And r.End(xlToLeft).Value = "" Then
        GoTo nxt
    End If
Set r = r.Offset(1, -(Cells.Columns.Count - 1))
 
r.Select
'r.EntireRow.Interior.ColorIndex = 8
For cnter = 0 To 81
    r.Offset(0, cnter).Value = "*"
Next cnter
        
 
End Sub
Private Sub FindFreeSeats()
Dim r As Range
Dim MaxRow As Long
Dim msgStr As String
Dim FreeCounter As Long
 
 
    Set r = Cells(4000, Cells.Columns.Count)
nxt:
        Set r = r.Offset(-1, 0)
        If r.End(xlToLeft).Column = 1 And r.End(xlToLeft).Value = "" Then
            GoTo nxt
        End If
        MaxRow = r.Row
        
Do Until MaxRow < 2
    If Cells(MaxRow, "E") = "" And Cells(MaxRow, "O") = "" And Cells(MaxRow, "Q") = "" Then
        Cells(MaxRow, "P") = "Free Seat"
        Cells(MaxRow, "AV") = "Chennai"
        FreeCounter = FreeCounter + 1
    End If
    MaxRow = MaxRow - 1
Loop
FreeSeats = FreeCounter
 
 
End Sub
 
Private Sub ChkForDupes()
Dim col As New Collection
Dim MaxRow As Long
Dim r As Range
 
DupeFound = False
 
MaxRow = Range("BO" & Cells.Rows.Count).End(xlUp).Row
 
If Range("BO3").Value <> "" Then
    Set r = Range("BO3")
Else
    Set r = Range("BO2").End(xlDown)
End If
 
On Error GoTo errhandler
    Do Until r.Row > MaxRow
        col.Add r.Address(False, False), UCase(r.Value)
        If r.Offset(1, 0).Value <> "" Then
            Set r = r.Offset(1, 0)
        Else
            Set r = r.End(xlDown)
        End If
    Loop
        
Exit Sub
errhandler:
DupeFound = True
ActiveWindow.ScrollColumn = r.Column
ActiveWindow.ScrollRow = r.Row
r.Select
 
MsgBox "Duplicate values were found in " & col.Item(r.Value) & " and " & r.Address(False, False) & _
vbNewLine & "Please repair", vbOKOnly + 16, "Can't continue"
 
End Sub

           
         

	Title
1	Mass movement code need to compare…
2	Mass Machine movement beteen rows…
3	Need a macro when run checks the co…
4	Mass movement script. Need the colo…
5	Check Mass Movement sheet check fo…

Move rows as per BO. Need to record them in comments.

Asked by bsharath in Microsoft Excel Spreadsheet Software, Microsoft Applications, Microsoft Office Suite

Tags: Excel, Macro

About this solution