Range("A4:A29").Select
Selection.ClearContents
Range("A34:A59").Select
Selection.ClearContents
Range("A64:A89").Select
Selection.ClearContents
Range("A94:A119").Select
Selection.ClearContents
Range("A124:A149").Select
Selection.ClearContents
Range("A154:A179").Select
Selection.ClearContents
Range("A184:A209").Select
Selection.ClearContents
Range("A1").Select
I did the above coding to clear some boxes in excel, but it does not give me flexibility over range of boxes, what I want is to clear out any filled boxes in column A but if x mod 30 equals to zero to skip the next 3 and so on. I have used a similar code to fill up the boxes, see below:
With RegExp
.Pattern = "\bT[0-9A-Z\(\)\-]+"
.Global = True
.IgnoreCase = False
Set matches = .Execute(txt)
End With
For Each Match In matches
If x Mod 30 = 0 Then
x = x + 4
End If
Cells(x, 1) = Match
x = x + 1
Cells(x, 1) = Match
If x Mod 30 <> 0 Then
x = x + 1
End If
Next
If anyone could help me that would be great! Thanks
It's a bad idea (performance-wise) to first select the cell and then use Selection.ClearContents
Try this principle:
Range(Cells(x, 1), Cells(x + 29, 1)) = ""
This clears the contents of all Cells between x,1 and x+29,1
For your purpose it might be something like this (you might have to tweek the details because they are not clear from your post):
For x = 0 to 9 ' repeat however many times you want
startingRow = x * 33 + 1
Range(Cells(startingRow, 1), Cells(startingRow + 28, 1)) = ""
Next
I got it. Thanks #E.Villager
Private Sub CommandButton2_Click()
Dim lRow As Long
Dim lCol As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = 4 To lRow
If x Mod 30 = 0 Then
x = x + 4
End If
Cells(x, 1) = ""
Next
End Sub
Related
I am new to VB and facing some issues to iterate through. below is my code and i want to iterate the if statement more than once.
Sub Refresh_Data()
On Error Resume Next
A = Worksheets("DATA").Cells(Rows.Count, 4).End(xlUp).Row
Dim x As String
x = 9550
For i = 1 To A
If Worksheets("DATA").Cells(i, 1).Value = x Then
Worksheets("DATA").Rows(i).Copy
Worksheets(x).Activate
B = Worksheets(x).Cells(Rows.Count, 4).End(xlUp).Row
Worksheets(x).Cells(B + 1, 1).Select
ActiveSheet.Paste
Worksheets("DATA").Activate
x = x + 50
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("DATA").Cells(1, 1).Select
End Sub
You are clearly making some rookie mistakes in your code, let me make some first corrections, and from there please tell us if you still have problems and in case yes, which ones:
Sub Refresh_Data()
' On Error Resume Next (do not use this, it is masking errors instead of solving them)
Dim A As Long
Dim B As Long ' not only A, also B
Dim x As Long ' x is not a string, but a number
Dim i As Long ' you forgot about i
A = Worksheets("DATA").Cells(Rows.Count, 4).End(xlUp).Row
x = 9550
For i = 1 To A
If Worksheets("DATA").Cells(i, 1).Value = x Then
Worksheets("DATA").Rows(i).Copy
Worksheets(x).Activate
B = Worksheets(x).Cells(Rows.Count, 4).End(xlUp).Row
Worksheets(x).Cells(B + 1, 1).Paste ' you can paste here directly, no reason to select first.
Worksheets("DATA").Activate
x = x + 50
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("DATA").Cells(1, 1).Select
End Sub
Goodevening,
with your help i can manage to multiply some elements on a right column with some other elements on a left column, but the elements on the left were seprated by blank cells.
What if there aren't blank space?
How can i do the condition in the cycle?
The previous code (with space) was this: (Thank you)
Sub test()
Dim x As Integer
Dim y As Integer
Range("A1").Select
x = 1
y = 1
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
If IsEmpty(Cells(x, "A")) = True Then
y = x + 1
End If
If IsEmpty(Cells(x, "A")) = False Then
Cells(x, "E").Value = Cells(x, "A").Value * Cells(y, "D").Value
End If
x = x + 1
ActiveCell.Offset(1, 0).Select
Loop
End Sub
This is the result i would like to achive: (so, the first number on column D will be multiplied for every number on the left Until the number on the column D change, and so goes on till the end)
Just a FYI, this could be done with a formula in E1:
=A1*LOOKUP(2,1/(D$1:D1<>""),D$1:D1)
I am a VBA beginner.
I want to copy cells from Sheet 1 into Sheet 2 in a certain sequential (in my case, after every 13 rows) with the condition of this: if any of the D2 to D32 in Sheet 1 is 0, copy A2 to A32 respectively. Then paste it in a sequential of +13 starting from B23 in Sheet 2.
For example:
if D2 is 0, copy A2 and paste it into B23 in Sheet 2.
if D3 is 0, copy A3 and paste it into B36 in Sheet 2.
If D4 is not 0, skip to next.
If D5 is 0, copy A5 and pate it into B49 in Sheet 2.
I feel that it is workable in VBA but I can't seem to figure it out.
I have searched the web but no answer came close to my requirement.
Sub Test()
Sheets("Sheet1").Select
For i = 2 To 32
If Sheets("Sheet1").Cells(i, 4) = 0 Then
Cells(i, 1).Copy
Else
End If
Sheets("Sheet2").Select
For j = 23 To 361 Step 13
Sheets("Sheet2").Cells(j, 2).PasteSpecial Paste:=xlPasteValues
Next j
Next i
End Sub
My current VBA keeps looping in Sheet2 until the end when the condition in Sheet1 is met. That's not what I want.
For flexibility in ranges, some speed using array and avoiding .Select and .PasteSpecial, you could try the following:
Sub Test()
Dim lr As Long, x As Long, z As Long, arr As Variant
With Sheets("Sheet1") 'Change accordingly
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A2:D" & lr).Value
End With
For x = LBound(arr) To UBound(arr)
If arr(x, 4) = 0 Then
Sheets("Sheet2").Cells(23 + z * 13, 2) = arr(x, 1)
z = z + 1
End If
Next x
End Sub
If you always just interested in A2:A32 then this will do:
Sub Test()
Dim x As Long, z As Long, arr As Variant
arr = Sheets("Sheet1").Range("A2:D32").Value
For x = LBound(arr) To UBound(arr)
If arr(x, 4) = 0 Then
Sheets("Sheet2").Cells(23 + z * 13, 2) = arr(x, 1)
z = z + 1
End If
Next x
End Sub
You'll benefit from reading this too.
Please try this
Sub Test()
Dim i As Integer, n As Integer
Sheets("Sheet1").Select
n = 0
For i = 2 To 32
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(i, 4) = 0 Then
Cells(i, 1).Copy
Sheets("Sheet2").Activate
Sheets("Sheet2").Cells(23 + (n * 13), 2).PasteSpecial Paste:=xlPasteValues
n = n + 1
Else
End If
'Sheets("Sheet2").Select
' For j = 23 To 361 Step 13
' Sheets("Sheet2").Cells(j, 2).PasteSpecial Paste:=xlPasteValues
' Next j
Next i
End Sub
Try this one:
Sub Test()
Dim i,j as integer
j= 1
Sheets("Sheet1").Activate
For i = 2 To 32
If Sheets("Sheet1").Cells(i, 4) = 0 Then
Sheets("Sheet2").Cells(10 + 13 * j, 2).Value2 = Cells(i, 1).Value2
j = j + 1
End If
Next
End Sub
Hope it helps
I am currently trying to develop that:
First, using a loop populates the numbers 0 to 1500 each like 8 columns apart, and then using another to loop to populate values from another worksheet but I want to use offset and so the numbers 0 to 1500 are the number of rows I want to offset each time. So 0 rows,1 row,2 rows etc.
I am trying to absolutely reference the column from which I will be offsetting the values on the other sheet (which is called DEX Spread Report (Corp)). However, I am having trouble absolutely referencing the column (Column D row 7) as I am not familiar with VBA's method.
Help would be much appreciated! Thanks
Sub Output_Numbers_For_Purpose_of_Offsetting_From_DexCorp()
Dim i As Integer
Dim m As Integer
Sheets("Sheet1").Select
Range("B1").Select
For i = 0 To 1500
ActiveCell.Value = i
ActiveCell.Offset(0, 8).Select
Next i
Range("B1").Select
For m = 0 To 1500
If ActiveCell.Value = m Then
ActiveCell.Offset(1, 0).Value = "=Offset('DEX Spread Report (Corp)'! (Range("D7").FormulaR1C1 = "C[0]*10"), m, 0)
Else: ActiveCell.Offset(1, 0).Value = ""
End If
ActiveCell.Offset(8, 0).Select
Next m
End Sub
EDIT - Incorporate Code from comments
I am getting an issue at:
ActiveCell.Offset(1, 0).Value = "=Offset('DEX Spread Report (Corp)'! (Range("D7").FormulaR1C1 = "C[0]*10"), m, 0)
I am trying to structure it as:
ActiveCell.Offset(1, 0).Value = Offset('DEX Spread Report (Corp)'!$D7,m,0 )
One way:
Dim r As Range
For Each r In Range("B1:B1000")
If r.Value = m Then
'stuff
Else
'stuff
End If
Next r
Another way:
Dim r As Range
Set r = Range("B1")
For m = 1 To 1500
If r(m, 1).Value = m Then
'stuff
Else
'something else
End If
Next m
If I'm following you correctly, you seem to be trying to get your formula to offset the $D7 reference as if you had manually pasted it into B2 and copied it across the worksheet.
I'll offer an alternative solution, since you seem to know that you'll always want to offset by 8 rows. Rather than deal with however VBA wants to absolute cell references, why not just calculate the row number? (m * 8) + 7 will give you $D7 at 0, $D15 for 1, and so on.
Sub Output_Numbers_For_Purpose_of_Offsetting_From_DexCorp()
Dim i As Integer
Dim m As Integer
Sheets("Sheet1").Select
Range("B1").Select
For i = 0 To 1500
ActiveCell.Value = i
ActiveCell.Offset(0, 8).Select
Next i
Range("B1").Select
For m = 0 To 1500
If ActiveCell.Value = m Then
ActiveCell.Offset(1, 0).Value = "=Offset('DEX Spread Report (Corp)'!$D" & (m * 8) + 7 & "," & m & ", 0)"
Else: ActiveCell.Offset(1, 0).Value = ""
End If
ActiveCell.Offset(0, 8).Select
Next m
End Sub
quite hard to follow your code
maybe you were for this:
Option Explicit
Sub Output_Numbers_For_Purpose_of_Offsetting_From_DexCorp()
Dim i As Long
With Sheets("Sheet1")
For i = 0 To 1500
.Range("B1").Offset(, i * 8) = i
Next i
For i = 0 To 1500
With .Range("B1").Offset(i * 8)
If .Value = i Then
.Offset(1, 0).Value = Worksheets("DEX Spread Report (Corp)").Range("D7").Offset(i + 6)
Else
.Offset(1, 0).Value = ""
End If
End With
Next i
End With
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