Looking to loop using columns, relatively new to looping and have some existing code which is incredibly cumbersome:
Sub AdvanceWeek2()
Application.ScreenUpdating = False
' Victor
' Week1
Range("V24:V124").Copy
Range("U24").PasteSpecial xlPasteValues
Range("V134:V234").Copy
Range("U134").PasteSpecial xlPasteValues
Range("V244:V334").Copy
Range("U244").PasteSpecial xlPasteValues
' Week2
Range("W24:W124").Copy
Range("V24").PasteSpecial xlPasteValues
Range("W134:W234").Copy
Range("V134").PasteSpecial xlPasteValues
Range("W244:W334").Copy
Range("V244").PasteSpecial xlPasteValues
' Week3
Range("W24:W124").ClearContents
Range("W134:W234").ClearContents
Range("W244:W334").ClearContents
' Nick
' Week1
Range("Z24:Z124").Copy
Range("Y24").PasteSpecial xlPasteValues
Range("Z134:Z234").Copy
Range("Y134").PasteSpecial xlPasteValues
Range("Z244:Z334").Copy
Range("Y244").PasteSpecial xlPasteValues
' Week2
Range("AA24:AA124").Copy
Range("Z24").PasteSpecial xlPasteValues
Range("AA134:AA234").Copy
Range("Z134").PasteSpecial xlPasteValues
Range("AA244:AA334").Copy
Range("Z244").PasteSpecial xlPasteValues
' Week3
Range("AA24:AA124").ClearContents
Range("AA134:AA234").ClearContents
Range("AA244:AA334").ClearContents
This then gets repeated for another 11 people, so you can see how cumbersome this gets. How would I go about automating this into a loop to shorten the code and make it easier to edit in the future if small changes needed to be made?
Try this
Sub AdvanceWeek2()
Application.ScreenUpdating = False
Dim var1 As Long, var2 As Long, cnt As Long
Dim rng As Range
var1 = 22 'for Column V
var2 = 100 'random max number
cnt = 13 'no of people
For i = var1 To var2
Range(Cells(24, i), Cells(124, i)).Copy Cells(24, i - 1)
Range(Cells(134, i), Cells(234, i)).Copy Cells(134, i - 1)
Range(Cells(244, i), Cells(334, i)).Copy Cells(244, i - 1)
If i Mod 2 = 1 Then
Union(Range(Cells(24, i), Cells(124, i)), Range(Cells(134, i), Cells(234, i)), Range(Cells(244, i), Cells(334, i))).ClearContents
i = i + 2
cnt = cnt - 1
If cnt = 0 Then Exit For
End If
Next i
Application.ScreenUpdating = True
End Sub
You'll have to start thinking in column numbers rather than column letters.
Column U is column 21 (U being the 21st letter in the alphabet).
You can reference U24 by either using Range("U24") or Cells(24,21) (row 24, column 21).
You reference a range of cells by giving it the first and last cells in the range, so Range(Cells(24,21),Cells(124,21)) will reference U24:U124 and is the same as writing Range("U24:U124").
Now for the looping bit. You want to reference column 21 for Victor, column 25 for Nick, column 29 for the next person, etc. So you'll increase this loop in steps of 4. You also need to reference different columns in each of these loops - moving column 2 to column 1, column 3 to column 2 and clearing column 3.
This bit of code will show how the loop works by printing the values to the immediate window. It will return 21 0, 21 1, 25 0, 25 1, 29 0, 29 1
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
Debug.Print x; y
Next y
Next x
End With
End Sub
These x and y values need to be used in your column references and seeing as you just want the values we can make one range of cells equal the other rather than copy/pastespecial.
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
.Range(.Cells(24, x + y), .Cells(124, x + y)).Value = .Range(.Cells(24, x + y + 1), .Cells(124, x + y + 1)).Value
.Range(.Cells(134, x + y), .Cells(234, x + y)).Value = .Range(.Cells(134, x + y + 1), .Cells(234, x + y + 1)).Value
.Range(.Cells(244, x + y), .Cells(334, x + y)).Value = .Range(.Cells(244, x + y + 1), .Cells(334, x + y + 1)).Value
Next y
.Range(.Cells(24, x + y), .Cells(124, x + y)).ClearContents
.Range(.Cells(134, x + y), .Cells(234, x + y)).ClearContents
.Range(.Cells(244, x + y), .Cells(334, x + y)).ClearContents
Next x
End With
End Sub
Add a watch for the values of X & Y and step through the code using F8. You'll see the values increase to reference the correct columns.
Note I've used the With..End With keywords. This means that each range that starts with a . is referencing Sheet1 of the workbook containing the code (ThisWorkbook).
Edit:
If you want to copy the cells (including formatting, formula, etc) then you can use:
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
.Range(.Cells(24, x + y + 1), .Cells(124, x + y + 1)).Copy Destination:=.Range(.Cells(24, x + y), .Cells(124, x + y))
.Range(.Cells(134, x + y + 1), .Cells(234, x + y + 1)).Copy Destination:=.Range(.Cells(134, x + y), .Cells(234, x + y))
.Range(.Cells(244, x + y + 1), .Cells(334, x + y + 1)).Copy Destination:=.Range(.Cells(244, x + y), .Cells(334, x + y))
Next y
Union(.Range(.Cells(24, x + y), .Cells(124, x + y)), _
.Range(.Cells(134, x + y), .Cells(234, x + y)), _
.Range(.Cells(244, x + y), .Cells(334, x + y))).ClearContents
Next x
End With
End Sub
(that union line could be used in the first example as well).
From your code it doesn't look like the username is important, just the fact there are 12 users.
12 users, 3 weeks...
A quick and minimal code approach is to:
Loop through your code 12 times (once for each user).
Have a nested loop for the 3 weeks per user, applying an offset to a base (or starting) column for each copy and paste operation.
Sub AdvanceWeek2()
Application.ScreenUpdating = False
Dim intLoopUser As Integer
Dim intLoopWeek As Integer
Dim rngBase As Range
Set rngBase = ActiveSheet.Range("V24:V124")
For intLoopUser = 0 To 35 Step 3 '12 Users, change the Step as required, looked like 3 from your code, maybe 4
For intLoopWeek = 0 To 2 '3 weeks
Select Case intLoopWeek
Case 0 'Week 1
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(0, intLoopUser + intLoopWeek).Value
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(110, intLoopUser + intLoopWeek).Value
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(210, intLoopUser + intLoopWeek).Value
Case 1 'Week 2
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(0, intLoopUser + intLoopWeek).Value
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(110, intLoopUser + intLoopWeek).Value
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(210, intLoopUser + intLoopWeek).Value
Case 2 'Week 3
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).ClearContents
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).ClearContents
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).ClearContents
End Select
Next intLoopWeek
Next intLoopUser
Application.ScreenUpdating = True
End Sub
Related
I have the below code in part of my excel vba that I need to amend but could do with some help understanding.
In cells T, W, and Z there is a sum if formula in row 2, this VBA replicates this formula down to the last row. I am trying to update the formula so that it does this for column T,W,Z,AC and AF
I've changed the 1-3 to 1-5 but it is debugging at the doc(ii) line.
Please could anyone help me up understand and update it.
Dim a, k, i As Long, ii As Long, t As Long, w(1 To 3), x, dic(1 To 3) As Object
With Range("k2", Range("k" & Rows.Count).End(xlUp))
k = .Value
a = .Columns(8).Resize(, 10).Value
End With
For i = 1 To 3
Set dic(i) = CreateObject("Scripting.Dictionary")
dic(i).CompareMode = 1
ReDim x(1 To UBound(a, 1), 1 To 1) As Double: w(i) = x
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
dic(ii)(a(i, (ii - 1) * 3 + ii + 1)) = i
Next
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
t = (ii - 1) * 3 + ii
If dic(ii).exists(a(i, t)) Then
x = w(ii)
x(dic(ii)(a(i, t)), 1) = x(dic(ii)(a(i, t)), 1) + k(i, 1)
w(ii) = x
End If
Next
Next
For i = 1 To 3
Cells(2, (i + 4) * 4).Resize(UBound(a, 1)).Value = w(i)
Next
End Sub
Recently I was helped with a code that fill down randomnly the cells based on Row#1 values. Answered_Post. (Thanks to #JvdV and #Scott Craner for assist me before.)
What I need to do now is almost the same, but the code will fill the cells leaping the columns as per random value (x) in a total of 10 rows. The repeatable values remain on Row#1.
Below the code provided on that post to fill down rows. I need now, as per picture, fill the columns.
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
Table_With_Sample_Values
Sub FillColumns01()
For y = 1 To 15
z = 0
j = 1
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If Cells(x, y) <> Cells(1, y) Then
Cells(y + 1, j) = Cells(1, y)
z = z + 1
j = j + 1
End If
Loop
Next y
End Sub
Sub FillColumns02()
'Using a 3rd Loop
Dim x As Integer, y As Integer, z As Integer, j As Integer
For y = 1 To 10
z = 0
Do While z < 4
For j = 1 To 15
x = Int((7 - 2 + 1) * Rnd + 2)
If Cells(x, y) <> Cells(1, y) Then
Cells(j, x) = Cells(1, y)
z = z + 1
End If
Next j
Loop
Next y
End Sub
Please help me to fix this,
Requirement:
Pasting data from sheet 1 to sheet x and skip to next page.
Problem:
I am unable to run the loop between 2 integers at a time.
I want to run the loop between x and y every time.But the written code is finishing x first and the going to y.
Please check below code and help me with u r ideas. Thank you.
Sub sbCopyValueToAnotherSheet()
Dim x As Integer
Dim y As Integer
For y = 2 To 11
For x = 2 To 50
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("F6")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("P6")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("P7")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("F8")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("P8")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("F9")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy Destination:=ActiveSheet.Range("P9")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy
Destination:=ActiveSheet.Range("F10")
y = y + 1
Sheets("Sheet1").Cells(x, y).Copy
Destination:=ActiveSheet.Range("P10")
y = y + 1
ActiveSheet.Next.Select
Next x
Next y
End Sub
If you are trying to copy 50 rows from Sheet1 into the same cells on 50 different sheets, try this:
Option Explicit
Public Sub sbCopyValueToAnotherSheet()
Dim x As Long, wsM As Worksheet, wsCount As Long
wsCount = ThisWorkbook.Worksheets.Count
Set wsM = ThisWorkbook.Worksheets("Sheet1")
For x = 2 To 50
With ThisWorkbook.Worksheets(x)
.Range("F6") = wsM.Cells(x, 2)
.Range("F7") = wsM.Cells(x, 3)
.Range("F8") = wsM.Cells(x, 4)
.Range("F9") = wsM.Cells(x, 5)
.Range("F10") = wsM.Cells(x, 6)
.Range("P6") = wsM.Cells(x, 7)
.Range("P7") = wsM.Cells(x, 8)
.Range("P8") = wsM.Cells(x, 9)
.Range("P9") = wsM.Cells(x, 10)
.Range("P10") = wsM.Cells(x, 11)
End With
If x = wsCount Then Exit Sub
Next
End Sub
I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i
This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.
I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub
My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub
T'm trying to format n ranges of 4 columns like below, expanding to the right and separated by a blank column (col "E"). The range 2 starts at column "F".
range 1
A B C D ...
X Action1 X X
-
-
X Action2 X X
X Action3 X X
#N/A #N/A #N/A
For each range, I want to remove rows (of 4 columns) containing "-" on the second column or "#N/A" on any column of the range, expecting this result :
range 1
A B C D ...
X Action1 X X
X Action2 X X
X Action3 X X
This is a part of a VBA macro so I won't use manual autofilters. On top, autofiltering would remove also rows from other ranges, which is not expected.
I'm trying this code at least for testing on the 1st block, even not working :
Dim Rng As Range
Set Rng = Range("A4", "D53")
If Not Rng(, 2).Value = "-" Then
Rng.Delete Shift:=xlUp
End If
edit : I guess the answer may not be far away from this but I can't manage it properly.
Lost in VBA, some help would be great, thx in advance
EDIT: if it may help someone, I ended up with this working code thx to the below hints :
Dim iRows, iCols, NbLig, x, BlockSize, BlockOffset, MyOffsetBtwnBlocks, CountBlocks As Integer
BlockSize = 4
NbLig = Range("A3").SpecialCells(xlCellTypeLastCell).Row
CountBlocks = 0
For iCols = 2 To NbCol Step BlockSize + 1
iRows = Range(Cells(3, iCols), Cells(NbLig, iCols + BlockSize).End(xlToLeft)).Rows.Count
For x = iRows To 3 Step -1
If Application.WorksheetFunction.IsNA(Cells(x, iCols + 1)) Then
Application.Intersect(Cells(x, iCols + 1).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
ElseIf Application.WorksheetFunction.IsNA(Cells(x, iCols + 2)) Then
Application.Intersect(Cells(x, iCols + 2).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
ElseIf Cells(x, iCols + 1).Value = "-" Then
Application.Intersect(Cells(x, iCols + 1).EntireRow, _
Range(Cells(3, iCols), Cells(3, iCols + BlockSize)).EntireColumn).Delete
End If
CountBlocks = CountBlocks + 1
Next x
Next iCols
This should do you:
Sub RemoveX()
Dim iRows As Integer
Dim x As Integer
Application.ScreenUpdating = False
iRows = Range("A1").CurrentRegion.Rows.Count
For x = iRows To 1 Step -1
If Application.WorksheetFunction.IsNA(Cells(x, 2)) Then
Application.Intersect(Cells(x, 2).EntireRow, _
Range("A1:D1").EntireColumn).Delete
ElseIf Cells(x, 2).Value = "-" Then
Application.Intersect(Cells(x, 2).EntireRow, _
Range("A1:D1").EntireColumn).Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
CurrentRegion is the region obtained if you click into A1 and press Ctrl-A.
If could be tidied up a little (using Range references and not using EntireRow or -Column) but it works.