I have the following loop written,
For X = 1 To N
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Next X
i = i + N
Which is supposed to start on a row (defined by i), and make new rows based on what N is. If N is equal to 20, I want this code to make 20 copies, then move onto the next row. However, on row 1, N = 3, and copy/pasting just seems to happen over and over. Any suggestions?
For context, the entire the code is as follows:
Sub NuPubPrepare()
Dim i As Long, k As Long, N As Long, Entry As Range, Rng As Range
i = 2
While i <= 400
Set Entry = Range("K" & i)
For k = Columns("K").Column To Columns("GB").Column Step 5
Set Entry = Union(Entry, Cells(i, k))
Next k
Set Rng = Range("D" & i)
N = Application.WorksheetFunction.CountA(Entry)
If N = 1 Then
i = i + 1
Else
For X = 1 To N
Rng.Offset(, -3).Resize(, 670).Copy
Rng.Offset(1, -3).Insert Shift:=xlDown
Next X
i = i + N
End If
Wend
End Sub
So N will count the number of cells with data in them across a wide range (Every 5 cells from Ki to GBi), and I'm trying to make the script insert new lines based on this number.
This will do as you ask.
Sub test()
Dim rng As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("1:1")
For i = 1 To 5
rng.Offset(1).Insert Shift:=xlDown
rng.Copy
rng.Offset(1).PasteSpecial xlPasteValues
Next i
End Sub
Related
This code successfully performs calculations on one of the worksheets in my workbook
Sub test()
Dim r As Range, j As Long, k As Long
j = Range("A1").End(xlToRight).Column
'changing the first value of k stops it adding up columns not required
For k = 8 To j - 1
Set r = Range(Cells(1, k), Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
Next k
End Sub
However I want the macro to run the same procedure on a selection of worksheets in my workbook. I found some code to 'wrap around' my existing code to allegedly perform the same procedure on each of the selected sheets but unfortunately it only performs the calculations on the sheet that is active at the time. So here is the code I am using (I am new to VBA)...
Sub test()
Dim WkSheets As Variant, SheetName As Variant, ws As Worksheet
'** SET The Sheet Names - MUST Reflect Each Sheet Name Exactly!
WkSheets = Array("Amazon DE FBA", "Amazon Fr", "Amazon Japan", "Bol", "CDiscount", "EBAY4", "Fragrancia")
For Each SheetName In WkSheets
MsgBox SheetName
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = SheetName Then
Dim r As Range, j As Long, k As Long
j = Range("A1").End(xlToRight).Column
'changing the first value of k stops it adding up un-needed columns
For k = 8 To j - 1
Set r = Range(Cells(1, k), Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
Next k
'End If
Next
Next
End Sub
The problem is that all Range and Cells calls need to be qualified with the Worksheet in question in these lines, otherwise they implicitly refer to the ActiveSheet.
j = Range("A1").End(xlToRight).Column
...
Set r = Range(Cells(1, k), Cells(1, k).End(xlDown))
That is easily done with a With statement and added periods:
With ws
Dim r As Range, j As Long, k As Long
j = .Range("A1").End(xlToRight).Column
'changing the first value of k stops it adding up un-needed columns
For k = 8 To j - 1
Set r = .Range(.Cells(1, k), .Cells(1, k).End(xlDown))
r.End(xlDown).Offset(2, 0) = WorksheetFunction.Sum(r)
Next k
End With
Note the periods . in .Range("A1") and .Range and .Cells(1, k)... now each of those is qualified with the worksheet in question, namely ws.
I have a sheet with some cells are merged in rows, and some are not. I want to wrap all the cells and if rows contains merged cells, set the rows height to max of all cells height
In the excel file, you can find the sheet I am working with, what I want to have, the excel macro I wrote, what I get with that macro. I also put them here.
This is what I have: (column D is a hidden column)
This is what I want to have: (for the rest of the sheet see attached excel file)
I wrote an excel VBA macro to do the job, but there is no luck.
Sub MergeCells2()
Application.DisplayAlerts = False
Dim allRange As Range
Dim xCell As Range
On Error Resume Next
Dim i_row As Integer
Dim nRowsToMerge As Integer
Dim rangeToMerge As Range
Worksheets("What I have").Activate
LastCol = ActiveSheet.Range("a1").End(xlToRight).Column
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, LastCol).End(xlUp).Row
Set allRange = Application.Range("a1", ActiveSheet.Cells(LastRow, LastCol))
allRange.WrapText = True
If allRange Is Nothing Then Exit Sub
nRowsToMerge = 1
Set heightToSet = Range("A2").RowHeight
For i_row = 2 To LastRow
Set i_rowRange = allRange.Rows(i_row - 1)
If (allRange.Cells(i_row, 1) = "") Then
nRowsToMerge = nRowsToMerge + 1
ElseIf nRowsToMerge = 1 Then
heightToSet = i_rowRange.RowHeight
Else
Set rangeToMerge = ActiveSheet.Range(ActiveSheet.Cells(i_row - nRowsToMerge, 1), ActiveSheet.Cells(i_row - 1, LastCol))
For Each xCell In rangeToMerge
cellrow = xCell.Row
If (rangeToMerge.Cells(cellrow, 1) = "") Then
If xCell.Value = "" Then
Range(xCell, xCell.Offset(-1, 0)).Merge
End If
End If
Next
rangeToMerge.RowHeight = heightToSet
heightToSet = i_rowRange.RowHeight
nRowsToMerge = 1
End If
Next i_row
End Sub
This is what I get:
I don't know what is wrong with it and I have to say that I don't know much about VBA programming.
I hope I was clear with my question.
Please help, I am working on this for days now :(
Cheers,
Eda
The idea:
Start by wrapping all cells, and using AutoFit for all rows. This way Excel will automatically set the row height properly.
Loop through the rows merging the cells and dividing the height of the row with the wrapped text over the rows to be merged.
This is how:
Sub NewMerger()
Dim r As Long, rMax As Long, re As Long, cMax As Long, c As Long, n As Long, h As Single, mr As Long
Application.DisplayAlerts = False
'Create a copy of the input
Sheets("What I have").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("New Result").Delete
ActiveSheet.Name = "New Result"
'merge and use autofit to get the ideal row height
Cells().WrapText = True
Rows.AutoFit
'get max row and column
cMax = Cells(1, 1).End(xlToRight).Column
rMax = Cells(Rows.Count, 1).End(xlUp).Row
'loop through rows, bottom to top
For r = rMax To 2 Step -1
If Cells(r, 1).Value = "" Then
If re = 0 Then re = r 'If we don't have an end row, we do now!
ElseIf re > 0 Then 'If re has an end row and the current row is not empty (AKA start row)
h = Rows(r).RowHeight 'Get the row height of the start row
n = re - r + 1 'calculate the number of rows
If n > 0 Then Rows(r & ":" & re).RowHeight = h / n 'devide the row hight over all rows
For c = 1 To cMax 'And merge
For mr = re To r Step -1 'Merge only empty cells
If Cells(mr, c).Value = "" Then
Range(Cells(mr, c), Cells(mr - 1, c)).MergeCells = True
End If
Next
Next
re = 0 'We don't have an end row now
End If
Next
Application.DisplayAlerts = True
End Sub
I want to retain any rows in excel which only contain "ECGS2A" or "ECGS2B" in column E and "Customer Opt In" in column M but having difficulty with trying different VBA codes.
I need to retain headers on row 4 but when trying to add range other than column E on:
j = Range("E" & Rows.Count).End(xlUp).Row
I get an error or "Run time error '1004': Method of 'Range' of object_Global' failed
' Deleting entire rows with MyTarget
Sub myDeleteRows2()
Const MyTarget = "*ECGS2A*"
Dim Rng As Range, DelCol As New Collection, x
Dim I As Long, j As Long, k As Long
' Calc last row number
j = Range("E" & Rows.Count).End(xlUp).Row
' Collect rows range with MyTarget
For I = 1 To j
If WorksheetFunction.CountIf(Rows(I), MyTarget) = 0 Then 'changed from > 0
k = k + 1
If k = 1 Then
Set Rng = Rows(I)
Else
Set Rng = Union(Rng, Rows(I))
If k >= 100 Then
DelCol.Add Rng
k = 0
End If
End If
End If
Next
If k > 0 Then DelCol.Add Rng
' Turn off screen updating and events
Application.ScreenUpdating = False
Application.EnableEvents = False
' Delete rows with MyTarget
For Each x In DelCol
x.Delete
Next
' Update UsedRange
With ActiveSheet.UsedRange: End With
' Restore screen updating and events
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
also tried
Sub DeleteRowsBasedOnMultipleCriteria()
lRow = 13 ' Your last row with the data
Do While lRow >= 1
'1=Column A,6=Column F, 18=Column R
If Cells(lRow, 5) = "ECGS9" _
Or Cells(lRow, 13) = "Customer Opt Out" Then
Rows(lRow).Delete
End If
lRow = lRow - 1
Loop
End Sub
I expect to be left with column E only displaying anything with ECGS2A or ECGS2B and column M as Customer Opt In. If the columns display anything other than those mentioned, I want them deleted.
Sub Macro1()
Dim LRow As Long, i As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") 'Change to your sheet name
LRow = .Range("E" & .Rows.Count).End(xlUp).Row
For i = LRow To 5 Step -1
If Not ((.Cells(i,5) Like "ECGS2A*" Or .Cells(i,5) Like "ECGS2B*") And .Cells(i, 13) Like "Customer Opt In*") Then
.Rows(i).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I want to copy gray cells to rows but only last column gray cell copied.
There's no need for nested loops
Sub Test()
Dim r As Integer, c As Integer
r = 3
For c = 3 To 21 Step 3
Cells(r, 1) = Cells(1, c)
r = r + 1
Next c
End Sub
You are so close :)
Option Explicit
Sub istebu()
Dim x As Long
Dim i As Long
For i = 3 To 10 'Loop in row from 3 to 10
For x = 3 To 21 Step 3 'Loop header row, from 3 to 21, jump 3
Cells(i, 1) = Cells(1, x) 'Copy values.
i = i + 1 'Add one row each time, so we don't overwrite previously row
Next x
Next i
End Sub
Alternative:
It could be shortened as we don't need to loop through the rows. We only need to add them. So we set i to the start row where we should paste our data.
Sub istebu()
Dim x As Long
Dim i As Long
i = 3 'Set first row number you want to loop from.
For x = 3 To 21 Step 3 'Loop header row, from 3 to 21, jump 3
Cells(i, 1) = Cells(1, x) 'Copy values.
i = i + 1 'Add one row each time, so we don't overwrite previously row
Next x
End Sub
There is an alternative to loops altogether.
Range("C1,F1,I1,L1,O1,R1,U1").Copy
Range("A3").PasteSpecial Paste:=xlPasteValues, Transpose:=True
But if you're really into loops, use one to build a union.
dim i as long, rng as range
for 3 to 21 step 3
if rng is nothing then
set rng = cells(1, i)
else
set rng = union(rng, cells(1, i))
end if
next i
rng.Copy
Range("A3").PasteSpecial Paste:=xlPasteValues, Transpose:=True
I am having trouble trying to include something into a macro I am building. I need it to search through column C
for cells that say "start trans" and in one column over (d)- the first value will be equal to zero, next instance should be 100, next instance 0 next instance 100 so on until the end of the data.
Instances are not always every 4th line and I have other zeros that I want it to overlook.
Thank you for any help!
How about this one:
Sub GoGoGo()
Dim l As Long: Dim i As Long
Dim b As Boolean
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 5 To l
If .Cells(i, "C").Value2 = "start trans" Then .Cells(i, "D").Value2 = b * -100: b = Not b
Next i
End With
End Sub
Try this.
Sub test()
Dim rngDB As Range, rng As Range
Dim n As Long, Result As Integer
Set rngDB = Range("c5", Range("c" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng = "start trans" Then
n = n + 1
If n Mod 2 Then
Result = 0
Else
Result = 100
End If
rng.Offset(0, 1) = Result
End If
Next rng
End Sub