I have recorded a macro that lets me split a persons monthly schedule into weeks.
Sub HoursSplit()
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-1]/4"
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-1]"
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[-1]"
ActiveCell.Offset(0, -3).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[1]"
End Sub
As an example:
Person
Month 2
Month 3
Person 1
173
173
Effectively:
I select the monthly hours im looking to split (i.e Month 2)
copy it
select a cell elsewhere with no data in it
Hit Cntrl + Shift + C
In the case above, it gives me
Cell 1
Cell 2
Cell 3
Cell 4
43.25
43.25
43.25
43.25
Thing is, this only works for a single person/cell, making splitting everyones hourshours up into weeks tedious.
How can i modify the above to work for an entire column range selection (i.e Multiple people at once for the same month)?
Another way you can do what you want (and should be faster).
Public Sub HoursSplit_Test()
Dim cell As Range
For Each cell In Selection
cell.Resize(, 4).Value = cell.Value / 4
Next cell
End Sub
Was able to solve my own issue eventually.
Public Sub HoursSplit_Test()
Dim cell As Excel.Range
For Each cell In Selection
cell.Value = cell.Value / 4
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 2).PasteSpecial
cell.Offset(0, 3).PasteSpecial
Next cell
End Sub
Related
Under the COUNTIF formula, I would like to look at the next column in response sheet after I move 2 rows down (ActiveCell.Offset). How should I go about that?
Can someone explain why when I want to look at column C, the coding is C3, while column D is C4?
Sub x()
Dim i As Integer
For i = 3 To 100
ActiveCell.Offset(4, 1).Range("A1").Select
Application.CutCopyMode = False
'ActiveCell.FormulaR1C1 = "=COUNTIF('Responses'!C4,data!R8C)"
ActiveCell.FormulaR1C1 = "=COUNTIF('Responses'!Ci,data!R8C)"
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:E1"), Type:= _
xlFillDefault
ActiveCell.Range("A1:E1").Select
ActiveCell.Offset(2, 0).Range("A1").Select
Next i
End Sub
I'm not sure what do you mean, but I rewrite that make your code more readable. Might be it will help you solve the matter. Can you explain more detail about the requirement?
Sub x()
Dim i As Integer
For i = 3 To 100
ActiveCell.Offset(4, 1).Select
ActiveCell.Formula = "=COUNTIF(Responses!R" & i & "C, data!R8C)"
Selection.AutoFill Destination:=ActiveCell.Range("A1:E1"), Type:=xlFillDefault
ActiveCell.Offset(2, 0).Select
Next
End Sub
The problem is that I have number of rows and in each row there is a string name for X number of columns.
I want to find these start column and end column and write the result into cells from same column but different row. The desire output is in start date and end date columns.
I tried to use If and counta functions, to count the length of the columns that have values and then somehow try to "go up" to the date row and write them to the start date and end date cells. Im struggling a bit how that is done in excel.
start Date: A4: =INDEX($D$1:$M$1,MATCH(TRUE,LEN($D4:$M4)>0,0))
end date: B4: =LOOKUP(2,1/(LEN($D4:$M4)>0),$D$1:$M$1)
Select A4:B4 and fill down as far as needed
If your table might be wider, replace the column M designation in the formulas with a column far out enough to always include the table, even XFD if you want.
For the last cell of column D, you could use this to get the last row number:
Range("D" & Rows.Count).End(xlUp).Row
For the first cell of column D, as you do not want to start from Row 1 (if I get it right), you could check values until non empty string starting from D2:
RowIndex = 1
Do
RowIndex = RowIndex + 1
cellValue = Range("D" & RowIndex).Value
Loop While cellValue = ""
Sub relative_fill()
Range("A2").Select
ActiveCell.SpecialCells(xlLastCell).Select
lr = ActiveCell.Row
lc = (ActiveCell.Column + 1)
i = 2
While i <= lr
r = -(i - 1)
Cells(i, 1).Select
Selection.End(xlToRight).Select
ActiveCell.Offset(r, 0).Select
Selection.Copy
Cells(i, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells(i, lc).Select
Selection.End(xlToLeft).Select
ActiveCell.Offset(r, 0).Select
Selection.Copy
Cells(i, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1
Wend
End Sub
I have to transpose rows to columns in excel using vba and the data is of around 500000.
The problem is that the data is not regular and is consistent.
Like there will be 4 rows then a blank then it can be three rows or one as well.
I want to transpose the group of data separated by a blank cell to be transposed to the the respective column in-front of the first entry.
Sub Transpose()
' Transpose Macro
' Keyboard Shortcut: Ctrl+Shift+T
Do Until IsEmpty(ActiveCell.Value)
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Loop
End Sub
I used this code but the problem is that it is skipping the data which is present in the single row.
Then this should do it, beware that I'm assuming where your data is and where is going to get paste, don't forget to change that:
Option Explicit
Sub Transpose()
Dim LastRow As Long 'last row on the sheet
Dim TransposeRow As Long 'row where we transpose
Dim x As Long 'columns
Dim C As Range 'faster looping through cells with For Each C in range
With ThisWorkbook.Sheets("MySheet") 'change this to your sheet
'To assign the last row im gonna assume your data is in column A or 1(B would be 2 and so...)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last row with data
TransposeRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'on column B will be pasting the data
x = 2 'initialize x being 2 as for B column
For Each C In .Range("A2:A" & LastRow)
If C = vbNullString Then 'in case the cell is blank we jump a row
TransposeRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 ' recalculate row for transposing data
x = 2 'reinitialize column counter
Else
.Cells(TransposeRow, x) = C 'we copy the value to the row and column empty
x = x + 1 'add 1 column
End If
Next C
End With
End Sub
I have edited your code to show an approach that can work for you. You need to add a condition for one cell data.
Sub Transpose2()
' Transpose Macro
' Keyboard Shortcut: Ctrl+Shift+T
Do Until IsEmpty(ActiveCell.Value)
If IsEmpty(ActiveCell.Offset(1, 0).Value) Then
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ActiveCell.Offset(0, -1).Range("A1").Select
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
End If
Application.CutCopyMode = False
Selection.End(xlDown).Select
Loop
End Sub
Note: Using select is not generally a good idea. An example of cutting down select would be:
Sub Transpose3()
' Transpose Macro
' Keyboard Shortcut: Ctrl+Shift+T
Do Until IsEmpty(ActiveCell.Value)
If IsEmpty(ActiveCell.Offset(1, 0).Value) Then
ActiveCell.Copy ActiveCell.Offset(0, 1)
Else
Range(ActiveCell, ActiveCell.End(xlDown)).Copy
ActiveCell.Offset(0, 1).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ActiveCell.Offset(0, -1).Range("A1").End(xlDown).Select
End If
Application.CutCopyMode = False
Selection.End(xlDown).Select
Loop
End Sub
I have a functioning macro that copy pastes the static values of live data from the live data sheet (Sheet), onto a separate sheet (Sheet2) every second. The code is below. For your information, Range("B2:B2195") are stock codes while Range("H2:H2195") are stock quotes.
Sub copypaste_RECENT()
Dim ab As Integer
Worksheets("Sheet").Range("B2:B2195").Copy
With Sheets("Sheet2")
.Range("B1").PasteSpecial Transpose:=True
ab = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(1, 1).Value = "Time"
.Cells(ab, 1).Value = Now
Worksheets("Sheet").Range("H2:H2195").Copy
.Range("B" & ab).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.OnTime Now + TimeSerial(0, 0, 1), "copypaste_RECENT"
End Sub
My next step is one that im having trouble with. I would like to record the difference between the stock quotes. This means calculating the difference between a certain cell and the cell above it and recording this difference onto a separate sheet (Sheet3). This would run simultaneously to the code above so I've tried to include an additional code after End With and before the Application. The code is below.
Worksheets("Sheet").Range("B2:B2195").Copy
With Sheets("Sheet3")
.Range("B1").PasteSpecial Transpose:=True
Dim xy As Long, yz As Long
ab = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
bc = .Cells(1, .Columns.Count).End(x1toleft).Column + 1
.Cells(1, 1).Value = "Time"
.Cells(ab, 1).Value = Now
xy = Worksheets("Sheet2").Cells(.Rows.Count, 1).End(x1up).Row
yz = Worksheets("Sheet2").Cells(.Rows.Count, 1).End(x1up).Row.Offset(-1, 0)
For ab = 1 To Cells(Rows.Count, 1).End(x1up).Row + 1
For bc = 1 To Cells(1, Columns.Count).End(x1toleft).Column + 1
.Cells(ab, bc).Value = xy - yz
Next ab
Next bc
End With
I'm quite new to VBA and I know this is completely wrong. I've been struggling for a while but I hope it makes some sort of sense.
Thanks in advance!
Grant
EDIT1: This is a simple computation that calculates the difference between a certain cell and the cell above it and records this value onto a separate sheet. This computation is done for every cell in the range.
I am not comletely cleat what you like to achieve. Is it alog, so you write consecutive lines of copied and computed entries, or is is just some computation. So depending on this you have at least three options:
1) copy/paste with math functions
using the copy/past with the special mathematical functions (add, substract, multiply, divide)
2) formulas
you enter in sheet3 the formuala into B2 =+sheet2!B4-sheet2!B3 which will compute this automatically.
3) compute an store the difference
make a computation as above and copy/paste the result to the final destination.
EDIT
Excel is designed to do computations! So why do you want to redo this?
You can do all of the mentioned solutions as VBA. The same way as you did is with your copy and paste above.
Here is a short makro which shows what I mean.
Sub Makro1()
'
' Makro1 Makro
'
'
ActiveCell.FormulaR1C1 = "Line 1"
Range("B1").Select
ActiveCell.FormulaR1C1 = "8"
Range("C1").Select
ActiveCell.FormulaR1C1 = "5"
Range("D1").Select
ActiveCell.FormulaR1C1 = "6"
Range("E1").Select
ActiveCell.FormulaR1C1 = "4"
Range("F1").Select
ActiveCell.FormulaR1C1 = "6"
Range("G1").Select
ActiveCell.FormulaR1C1 = "3"
Range("A2").Select
ActiveCell.FormulaR1C1 = "12"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Line 2"
Range("B2").Select
ActiveCell.FormulaR1C1 = "15"
Range("C2").Select
ActiveCell.FormulaR1C1 = "456"
Range("D2").Select
ActiveCell.FormulaR1C1 = "23"
Range("E2").Select
ActiveCell.FormulaR1C1 = "42"
Range("F2").Select
ActiveCell.FormulaR1C1 = "45"
Range("G2").Select
ActiveCell.FormulaR1C1 = "77"
Range("A1:G1").Select
Selection.Copy
Range("A5").Select
ActiveSheet.Paste
Range("B2:G2").Select
Application.CutCopyMode = False
Selection.Copy
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlSubtract, _
SkipBlanks:=False, Transpose:=False
End Sub
I was wondering if it is possible for someone to help me shorten the code as i'm afraid it might take a long time to run after i add in other codes. What i want to do will be explain in the following:
I want to copy say test2 (do take note that the spacing means the variables are on their own row and column)
test1 1 2 1
test2 2 1 4
test3 1 1 1
After copying it I will paste it at some other sheet.
Let say, I have another set of results
Say
test2 2 1 4
test3 3 9 8
test5 1 1 1
I wanted to copy test2 but my VBA coding werent able to as it still assumes that test2 is at 2nd row.
And one last case would be, if test2 not available, it will continue on copying the rest of the result and paste it at other sheets.
I have did some coding, do run through and help me solve this problem. THANKS!
Sub Macro1()
iMaxRow = 6 ' or whatever the max is.
'Don't make too large because this will slow down your code.
' Loop through columns and rows
For iCol = 1 To 1 ' or however many columns you have
For iRow = 1 To 1
With Worksheets("Sheet3").Cells(iRow, iCol)
' Check that cell is not empty.
If .Value = "Bin1" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin2" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin3" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin4" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin5" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin6" Then
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow
Next iCol
For iCol1 = 1 To 1 ' or however many columns you have
For iRow1 = 1 To 2
With Worksheets("Sheet3").Cells(iRow1, iCol1)
' Check that cell is not empty.
If .Value = "Bin2" Then
Range("A2:G2").Select
Selection.Copy
Sheets("sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin3" Then
Range("A2:G2").Select
Selection.Copy
Sheets("sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin4" Then
Range("A2:G2").Select
Selection.Copy
Sheets("sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin5" Then
Range("A2:G2").Select
Selection.Copy
Sheets("sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin6" Then
Range("A2:G2").Select
Selection.Copy
Sheets("sheet4").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow1
Next iCol1
For iCol2 = 1 To 1 ' or however many columns you have
For iRow2 = 1 To 3
With Worksheets("Sheet3").Cells(iRow2, iCol2)
' Check that cell is not empty.
If .Value = "Bin3" Then
Range("A3:G3").Select
Selection.Copy
Sheets("sheet4").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin4" Then
Range("A3:G3").Select
Selection.Copy
Sheets("sheet4").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin5" Then
Range("A3:G3").Select
Selection.Copy
Sheets("sheet4").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin6" Then
Range("A3:G3").Select
Selection.Copy
Sheets("sheet4").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow2
Next iCol2
For iCol3 = 1 To 1 ' or however many columns you have
For iRow3 = 1 To 4
With Worksheets("Sheet3").Cells(iRow3, iCol3)
' Check that cell is not empty.
If .Value = "Bin4" Then
Range("A4:G4").Select
Selection.Copy
Sheets("sheet4").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin5" Then
Range("A4:G4").Select
Selection.Copy
Sheets("sheet4").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin6" Then
Range("A4:G4").Select
Selection.Copy
Sheets("sheet4").Select
Range("A4").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow3
Next iCol3
For iCol4 = 1 To 1 ' or however many columns you have
For iRow4 = 1 To 5
With Worksheets("Sheet3").Cells(iRow4, iCol4)
' Check that cell is not empty.
If .Value = "Bin5" Then
Range("A5:G5").Select
Selection.Copy
Sheets("sheet4").Select
Range("A5").Select
ActiveSheet.Paste
Sheets("sheet3").Select
ElseIf .Value = "Bin6" Then
Range("A5:G5").Select
Selection.Copy
Sheets("sheet4").Select
Range("A5").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow4
Next iCol4
For iCol5 = 1 To 1 ' or however many columns you have
For iRow5 = 1 To 6
With Worksheets("Sheet3").Cells(iRow5, iCol5)
' Check that cell is not empty.
If .Value = "Bin6" Then
Range("A6:G6").Select
Selection.Copy
Sheets("sheet4").Select
Range("A6").Select
ActiveSheet.Paste
Sheets("sheet3").Select
End If
End With
Next iRow5
Next iCol5
Sheets("Sheet4").Select
Range("A1").Select
End Sub
I am struggling to identify what your code does. Below I specify some simplifications and other necessary improvements but there may be more once we have cleared the brushwood.
Change 1
Please use Option Explicit and please declare your variables. This avoids a misspelt variable being taken as a new implicit declaration.
Change 2
Please use Application.ScreenUpdating = False. This avoids repainting the screen as the macro works through its tasks. This would have been essential with your code because of all the switching between sheets. It is less important with my code because I do not switch sheets.
Change 3
Replace:
With Sheets("Sheet3")
:
Range("A1:G1").Select
Selection.Copy
Sheets("sheet4").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("sheet3").Select
:
End With
by:
With Sheets("Sheet3")
:
.Range("A1:G1").Copy Destination:=Worksheets("Sheet4").Range("A1")
:
End With
This avoids switching sheets which is the biggest waste of time.
Change 4
For each If-ElseIf-ElseIf-EndIf you do the same copy. So:
If .Value = "Bin1" Or .Value = "Bin2" Or .Value = "Bin3" _
.Value = "Bin4" Or .Value = "Bin5" Then
would have the same effect.
Summary so far
I believe the following does exactly the same as your first loop:
Option Explicit
Sub Macro1()
Dim iCol As Long
Dim iRow As Long
Dim ValueCell as String
With Sheets("Sheet3")
For iCol = 1 To 1
For iRow = 1 To 1
ValueCell = .Cells(iRow, iCol).Value
If ValueCell = "Bin1" Or ValueCell = "Bin2" Or ValueCell = "Bin3" Or _
ValueCell = "Bin4" Or ValueCell = "Bin5" Then
.Range("A1:G1").Copy Destination:=Worksheets("Sheet4").Range("A1")
End If
Next
Next
End With
End Sub
Possible further change
Are the loops really independent? To me it looks as though you could merge them into a single loop.
New section added in response to exchange of comments
Consider the code in your question:
You have six double loops.
In every case, the outer loop is For iCol = 1 to 1. That is, you only examine column "A" although you imply you would examine more columns if the code was faster.
The inner loop is For iRow = 1 to №. № is 1 in the first loop, 2 in the second and 6 in the sixth loop. Again you imply you would examine more rows if the code was faster.
The action for each loop depends on the value of №.
Table showing effect of № of action:
Value
of № Cells examined Values checked for Range moved
1 A1 "Bin1" ... "Bin6" A1:G1
2 A1, A2 "Bin2" ... "Bin6" A2:G2
3 A1, A2, A3 "Bin3" ... "Bin6" A3:G3
4 A1, A2, ... A4 "Bin4" ... "Bin6" A4:G4
5 A1, A2, ... A5 "Bin5", "Bin6" A5:G5
6 A1, A2, ... A6 "Bin6" A6:G6
That is, in double loop №, you examine cells A1 to A№, check for values "Bin№" to "Bin6" and if found, you copy Sheets("Sheet3").Range("A№:G№") to Sheets("Sheet4").Range("A№).
In your text and example data, you refer to "text2" instead of "Bin2". I do not understand what you are trying to do. Below, I introduce some more VBA which may help you create the code you want. If it does not, you will have to add a new section to your question explaining in English what you are trying to do.
New syntax 1
Consider:
For iRow = 1 to 6
:
.Range("A6:G6").Copy Destination:=Worksheets("Sheet4").Range("A6")
:
Next
"A6:G6" and "A6" are strings that you can build at runtime.
Now consider:
For iRow = 1 to iRowMax
:
.Range("A" & iRowMax & ":G" & iRowMax)).Copy _
Destination:=Worksheets("Sheet4").Range("A" & iRowMax)
:
Next
According to the value of iRowMax this gives:
iRow Statement
1 .Range("A1:G1")).Copy Destination:=Worksheets("Sheet4").Range("A1")
2 .Range("A2:G2")).Copy Destination:=Worksheets("Sheet4").Range("A2")
3 .Range("A3:G3")).Copy Destination:=Worksheets("Sheet4").Range("A3")
New syntax 2
Another way of changing a range at runtime is to replace:
.Range(string)
with
.Range(.Cells(RowTop,ColLeft),.Cells(RowBottom,ColRight))
With this syntax you can easily specify a rectangle of the size required.
New syntax 3
Consider:
For i = 1 to 5
If this(i) = that Then
Do something fixed
Exit For
End If
Next
' Exit For statement jumps to here
In this loop, I am testing five values. If any match, I do something. If I get a match on the first value, I do not need to check the other values. Exit For allows me to jump out of the For-Loop. If there are nested For-Loops, Exit For only exits the inner loop
New syntax 4
"Bin1", "Bin2" and so on can also be created at runtime.
iRowMax = 4
For iRow = 1 to iRowMax
For iBin = iRowMax to 6
If ValueCell = "Bin" & iBin Then
' Move Range
Exit For
End If
Next
' Exit For statement jumps to here
Next
With iRow = 4, the inner For-Loop sets iBin to 4, 5 and 6. This sets "Bin" & iBin to "Bin4", "Bin5" and "Bin6".
So:
For BinNum = iRowMax to 6
If ValueCell = "Bin" & BinNum Then
' Move Range
Exit For
End If
Next
is the same as:
If ValueCell = "Bin4" Or ValueCell = "Bin5" Or ValueCell = "Bin6" Then
' Move Range
End If
This new code is more complicated and is more difficult to understand than the original, but it may be what you need.
Summary
I have shown you different ways of changing what happens depending on the value of iRow. I hope one of them will allow you to build the routine you want.
I have not tested it but I think this does the same as all six loops in your original code:
Option Explicit
Sub Macro1()
Dim iBin as Long
Dim iCol As Long
Dim iRow As Long
Dim iRowMax as Long
Dim ValueCell as String
Application.ScreenUpdating = False
With Sheets("Sheet3")
For iRowMax = 1 to 6
For iCol = 1 To 1 ' This could be replaced by iCol = 1 at the top
For iRow = 1 To iRowMax
ValueCell = .Cells(iRow, iCol).Value
For iBin = iRowMax to 6
If ValueCell = "Bin" & iBin Then
.Range("A" & iRowMax & ":G" & iRowMax)).Copy _
Destination:=Worksheets("Sheet4").Range("A" & iRowMax)
End If
Next iBin
Next iRow
Next iCol
End With
End Sub
Note: only removing all the Select statements makes this code faster than yours. The other changes make it smaller and very slightly slower because I have two extra For-Loops and I am building strings at runtime.