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
Related
I am using below code in one workbook as the following:
(1) Match a range on SheetA against a range on SheetB.
(2) If the data found on SheetB, then some values will be inserted on SheetB and Sheet Log.
(3) The matched data (rows) on SheetB will be copied to Sheet Result and Autofit.
(4) The matched data (rows) on SheetB will be cleared. (cut & paste is not applicable).
The count of values on the first range in SheetA is normally 7 or 8 and this macro was as fast as it takes 2 seconds to finish all that steps.
I tried to put 146 values on the first range, but the macro turned to be very slow and it took 35 seconds to finish.
Please, how to speed up and optimize this macro?
Note: there is no problem at all to change match code or copy, paste, autofit and clear code.
Link for the full macro and sheet on the first comment.
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
Please, check the next adapted code. It uses arrays for faster iteration and for faster results return. Also, setting the row height for each cell consumes Excel resources. I commented some rows but no time now for everything. If something unclear, please do not hesitate to ask for clarifications:
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k + 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
Dim rngClearCont As Range
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k + 1
If rngClearCont Is Nothing Then
Set rngClearCont = StatusColumn.Cells(i) 'set the range necessary to clear rows at the end
Else
Set rngClearCont = Union(rngClearCont, StatusColumn.Cells(i))
End If
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
rngClearCont.EntireRow.ClearContents
End If
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
It should take less than a second...
The root of your issue is that you are making many edits to the worksheet. One of the first ways to speed up VBA code is to reduce the number of times you write data to the sheet.
Rather than writing your data to the sheet every time in a For Each loop, add all of your data to an Array and then write that entire Array to the sheet(s) at once. This way, you don't have to write multiple times for every For Each loop, but only once.
I cannot guarantee that this is the only reason your code is "sub-optimal" but it's a good place to start to improve performance times.
While writing to the sheet does take time, the main problem here is the copy/paste part.
If you, after the row
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
Put something like:
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
And then remove the copy/paste part completely, you should be able to run it almost instantly.
I would like to delete all empty columns between 2 used ranges, based on the screenshot:
However, these two used ranges may have varying column length, thus the empty columns are not always Columns D to K.
Here is my code:
Sub MyColumns()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.Open ("BOOK2.xlsx")
Workbooks("BOOK2.xlsx").Activate
Workbooks("BOOK2.xlsx").Sheets(1).Activate
Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, 4).Value = "NON-EMPTY"
Dim finalfilledcolumn As Long
finalfilledcolumn = Workbooks("BOOK2.xlsx").Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Dim iCol As Long
Dim i As Long
iCol = firstfilledcolumn + 1
'Loop to delete empty columns
For i = 1 To firstfilledcolumn + 1
Columns(iCol).EntireColumn.Delete
Next i
Workbooks("BOOK2.xlsx").Close SaveChanges:=True
MsgBox "DONE!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
However, the empty columns still remain.
Do note that the last filled column for the first used range, Place = "USA", Price = "110" and Category = "Mechanical" may not be fixed at Column C, but could go to Column D, E, etc.
Many thanks!
Please, try the next way:
Sub deleteEmptyColumn()
Dim sh As Worksheet, lastCol As Long, rngColDel As Range, i As Long
Set sh = ActiveSheet 'use here your necessary sheet, having the workbook open
'if not open, you can handle this part...
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column
For i = 1 To lastCol
If WorksheetFunction.CountA(sh.Columns(i)) = 0 Then
If rngColDel Is Nothing Then
Set rngColDel = sh.cells(1, i)
Else
Set rngColDel = Union(rngColDel, sh.cells(1, i))
End If
End If
Next i
If Not rngColDel Is Nothing Then rngColDel.EntireColumn.Delete
End Sub
Try this ..
Dim rng As Range, i As Long
Set rng = Workbooks("BOOK2.xlsx").Sheets(1).UsedRange
For i = rng.Columns.Count To 1 Step -1
If WorksheetFunction.CountA(rng.Columns(i)) = 0 Then
rng.Columns(i).EntireColumn.Delete
End If
Next i
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
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 am trying to copy all rows from an excel sheet (Sheet1) that have a specific value that is referenced from a different cell. and then paste them into a new sheet(Sheet2).
My specific example is I have figured out that I want to copy the rows that have a '0' and/or '35' in column A. these values can change however due to what ever is in "B6" and "B7".
The problem that I am having is it only copys rows that contain the value from "B6" which is 0 and ignoring my command that wants the "B7" value which is 35 in my instance. My code is below for reference
Sub Temp_copy()
set i = Sheets("Sheet1")
set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A"&j) = Range("B6"&j) Then
d=d+1
e.Rows(d).Value=i.Rows(j).Value
End If
j = j+1
Loop
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A"&j) = Range("B7"&j) Then
d=d+1
e.Rows(d).Value=i.Rows(j).Value
End If
j = j+1
Loop
End Sub
I am new to VBA so any help or guidance to achieve what I need would be muchly appreciated.
Instead of looping through cells, you may use Autofilter to copy the desired data like below...
Sub CopyRows()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Sheet2")
lr = sws.Cells(Rows.Count, 1).End(xlUp).Row
dws.Cells.Clear
sws.AutoFilterMode = False
'Assuming Row1 is the Header Row on Sheet1
With sws.Range("A1:A" & lr)
.AutoFilter field:=1, Criteria1:=sws.Range("B6").Value, Operator:=xlOr, Criteria2:=sws.Range("B7").Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
dws.Range("A1").PasteSpecial xlPasteValues
End With
sws.AutoFilterMode = False
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
The simple or operator will help you get this done!
Sub Temp_copy()
Set i = Sheets("Sheet1")
Set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) = Range("$B$6") Or i.Range("A" & j) = Range("$B$7") Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub