I've got the function mergeSimilarAdjacentCells for merging my Excel headers in the first row.
The headers in the first row start in an unknown column and also finishes in an unknown column.
The function works for me but I'm getting this message for each merge!
Example of the input data:
The output I got:
What should I do to stop getting these popup messages?
My code:
Function mergeSimilarAdjacentCells()
Dim Rng_headers As Range
Dim numOfDataCols As Long
Dim myCell As Variant
numOfDataCols = ActiveSheet.Cells(1, Columns.count).End(xlToLeft).Column
Set Rng_headers = Range("A" & 1 & ":" & Col_Letter(numOfDataCols) & 1)
MergeAgain:
For Each myCell In Rng_headers
If myCell.Value = myCell.Offset(0, 1).Value And IsEmpty(myCell) = False Then
Range(myCell, myCell.Offset(0, 1)).Merge
GoTo MergeAgain
End If
Next
End Function
Please try this way when merging:
'your existing code
For Each myCell In Rng_headers
If myCell.value = myCell.Offset(0, 1).value And IsEmpty(myCell) = False Then
Application.DisplayAlerts = False
Range(myCell, myCell.Offset(0, 1)).merge
Application.DisplayAlerts = True
GoTo MergeAgain
End If
Next
The message is normal, Excel wants preventing data loosing by mistake, if you do not know that only the Top-left value is kept.
Related
I known, this question has been asked thousands of times. But every time I picked up a solution appears error when i debug. (error 1004)
I work with a database with about 300000 lines, where more than half do not care. (I know that have filter, but wanted to erase to reduce the file and speed up the process).
Then if the column M has a keyword like "water", "beer" or "vodka" it will delete the row. I mean, don't need to be the exact word, just the keyword.
OBS: Row 1 it's a table title with the frozen line.
Thanks!
The following code works less than 4 seconds for processing your sample data on my machine:
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet, Data As Range
Dim Sheet_Name As String, Text As String, Water As Long, Beer As Long, Vodka As Long
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("SOVI")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Output(1 To LastRow - 1, 1 To 1) As Long
For i = 1 To LastRow - 1
Text = Cells(i + 1, 13)
Water = InStr(Text, "water")
Beer = InStr(Text, "beer")
Vodka = InStr(Text, "vodka")
If Water > 0 Or Beer > 0 Or Vodka > 0 Then Output(i, 1) = 1
Next
[S2].Resize(LastRow - 1, 1) = Output
LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range(Cells(1, 1), Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=19, Criteria1:="=1"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
NewSheet_Data.Columns(19).Clear
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub
In the future, please post code you've tried first for the community to help you out. That being said, try this out:
Sub Test()
Dim x as Long
Dim i as Long
x = Sheets("SOVI").Range("M" & Rows.Count).End(xlUp).Row
For i = x to 2 Step -1
If InStr(1, Range("M" & i).Value, "water", vbTextCompare) Or InStr(1, Range("M" & i).Value, "beer", vbTextCompare) Or InStr(1, Range("M" & i).Value, "vodka", vbTextCompare) Then
Range("M" & i).entirerow.delete
End If
Next i
End Sub
I would use a slightly different approach, with the Like and with Select Case - this will give you more versatility in the future if you would want to expand it to more types of drinks.
Sub FindDrink()
Dim lRow As Long
Dim i As Long
Dim sht As Worksheet
' always set your sht, modify to your sheet name
Set sht = ThisWorkbook.Sheets("Sheet1")
lRow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
For i = lRow To 2 Step -1
Select Case True
Case (sht.Cells(i, "M").Value Like "*beer*") Or (sht.Cells(i, "M").Value Like "*water*") Or (sht.Cells(i, "M").Value Like "*vodka*")
Range("M" & i).EntireRow.Delete
Case Else
' if you decide to do other things in the future for other values
End Select
Next i
End Sub
use excel built in filtering functions for the maximum speed
Autofilter
Option Explicit
Sub main()
Dim keysToErase As Variant, key As Variant
keysToErase = Array("water", "beer", "vodka") '<--| list your keywords to delete matching column "M" rows with
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
For Each key In keysToErase '<--| loop through keys
.AutoFilter field:=13, Criteria1:="*" & key & "*" '<--| filter column "M" with key
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
Next key
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
AdvancedFilter
Option Explicit
Sub main2()
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("U1:U4") '<--| this filters on all keys you placed in cells "U2:U4" with cell "U1" with wanted data header
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
Try with Below code
Sub test()
Application.DisplayAlerts = False
Dim lastrow As Long
Dim i As Long
Dim currentrng As Range
lastrow = Range("M" & Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
Set currentrng = Range("M" & i)
If ((currentrng Like "*water*") Or (currentrng Like "*beer*") Or (currentrng Like "*vodka*")) Then
currentrng.EntireRow.Delete shift:=xlUp
End If
Next i
Application.DisplayAlerts = True
End Sub
I need to copy values only without Formula from sheet to another. The following code does copy but only with Formula. I tried some solutions presented in this site but they give me errors.
For i = 2 To LastRow
'sheet to copy from
With Worksheets("Hoist")
'check column H value before copying
If .Cells(i, 8).Value >= -90 _
And CStr(.Cells(i, 9).Value) <> "Approved" _
And CStr(.Cells(i, 9).Value) <> "" _
And CStr(.Cells(i, 10).Value) = "" Then
'copy row to "display" sheet
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
j = j + 1
End If
End With
Next i
Try changing this line:
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
to this:
.Rows(i).Copy
Worksheets("display").Range("A" & j).PasteSpecial xlPasteValues
This however drops all formatting. To include formatting, you'll need to add another line like:
Worksheets("display").Range("A" & j).PasteSpecial xlPasteFormats
Another option is to enter a working column and use AutoFilter to avoid loops
insert a column in column A
the working column formuka is =AND(I2>-90,AND(J2<>"",J2<>"Approved"),K2="")
filter and copy the TRUE rows
delete working column A
code
Sub Recut()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Hoist")
ws.AutoFilterMode = False
Set rng1 = Range([h2], Cells(Rows.Count, "H").End(xlUp))
ws.Columns(1).Columns.Insert
rng1.Offset(0, -8).FormulaR1C1 = "=AND(RC[8]>-90,AND(RC[9]<>"""",RC[9]<>""Approved""),RC[10]="""")"
With rng1.Offset(-1, -8).Resize(rng1.Rows.Count + 1, 1).EntireRow
.AutoFilter Field:=1, Criteria1:="TRUE"
.Copy Sheets("display").Range("A1")
Sheets("display").Columns("A").Delete
End With
ws.Columns(1).Delete
ws.AutoFilterMode = False
End Sub
I have written a script which checks a range of cells in column range 4 (Column D) for non-blank values, if it finds a non blank value, it copies that value and pastes it to a cell in column range 6 (Column F). The script runs, but it is awfully slow, the script takes 5 minutes to process and complete its run. Is there any way to improve this script so that it can pre-check the range before it copies and pastes the values across? It seems that the copy / paste function is slowing it down.
Code below
Sub ArrayCopyPaste()
Dim J as Integer
Application.Calculation = xlCalculationManual
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 4).Copy
Cells(J, 6).PasteSpecial Paste:=xlPasteValues
End If
Next J
Application.Calculation = xlCalculationAutomatic
End Sub
Here's one way:
Sub test()
Dim r1, r2, n As Long
With Sheets("Sheet1") '~~> change to suit
Dim lrow As Long
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
r1 = Application.Transpose(.Range("D2:D" & lrow))
r2 = Application.Transpose(.Range("F2:F" & lrow))
For n = LBound(r1) To UBound(r1)
If r1(n) <> "" Then r2(n) = r1(n)
Next
.Range("F2:F" & lrow) = Application.Transpose(r2)
End With
End Sub
Transfer range data to array, then do the comparison process array to array.
Then return the array to range. HTH.
Important: Application.Transpose have limitation. I can handle only a few thousand data.
Follow up: Try this for deleting
Dim rngToDelete As Range, k As Long
With Sheets("Sheet1") '~~> change to suit
For k = 2 To 500
If .Cells(k, 6).Value = "" Then
If rngToDelete Is Nothing Then
Set rngToDelete = .Cells(k, 6)
Else
Set rngToDelete = Union(rngToDelete, .Cells(k, 6))
End If
End If
Next
rngToDelete.Delete xlUp
'rngToDelete.EntireRow.Delete xlUp ~~> use this if you want to delete entire row.
End With
Determine all the target range first then delete in one go. HTH.
Try simply doing this first and see if it makes a difference:
Dim currentCalculation As Variant
currentCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 4).Copy
Cells(J, 6).PasteSpecial Paste:=xlPasteValues
End If
Next J
Application.ScreenUpdating = True
Application.Calculation = currentCalculation
Another thought. Have you tried just doing this?
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 6).Value = Cells(J, 4).Value
End If
Next J
It won't make any difference to your target column if the blanks are copied, so don't bother checking for them. Don't loop -- just copy the entire column.
Sub CopyColumn()
' copying this way does not use your clipboard
Columns("D").Copy Columns("F")
End Sub
If you only need a portion of the column, specify the range to copy rather than the entire column:
Sub CopyPartOfColumn()
' copying this way does not use your clipboard
Range("D2:D500").Copy Range("F2:F500")
End Sub
You mention in a comment below your question that you want the resulting column to be a consolidated list of the values without the blanks. You can quickly do that by deleting the blanks from the column or range, once again without looping. Run this after you've copied the values you want.
Sub RemoveBlanks()
Range("F2:F500").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
I have a code to look for the word "it" in column B.Then if the code finds it, it copies the cell to the right of it to another worksheet. Would anyone know how to modify it so it reads the second "it" in column B, not the first? Thank you
Dim rcell As Range
Application.ScreenUpdating = False
For Each rcell In Range("B2:B" & ActiveSheet.UsedRange.Rows.count + 1)
If rcell.Value = "it" Then
rcell.Offset(, 1).Copy Sheets("another sheet").Range("C" & Rows.count).End(3)(2)
End If
Next rcell
Application.ScreenUpdating = True
End Sub
Try this:
Dim rcell As Range
Application.ScreenUpdating = False
For Each rcell In Range("B2:B" & ActiveSheet.UsedRange.Rows.count + 1)
Dim place%
'find first instance of "it"
place = InStr(1,rcell.Value, "it")
If place <> 0 Then
'if there is one, check to see if there is a second instance
'line below may have to use place+1 instead of just place
If InStr(place,rcell.Value, "it") <> 0 Then
rcell.Offset(, 1).Copy Sheets("another sheet").Range("C" & Rows.count).End(3)(2)
End If
End If
Next rcell
Application.ScreenUpdating = True
End Sub
I have a Do Until loop in VBA.
My problem is that there is likely to be an error most days when running the macro as not all the sheets will have info on them.
When that happens I just want to start the loop again. I am assuming its not the "On Error Resume Next" I was thinking of counting the rows on the autofilter and then if it was 1 (ie only titles) starting the loop again. Just not sure how to do that.
Dim rngDates As Range 'range where date is pasted on.
'Dim strDate As String
Dim intNoOfRows As Integer
Dim rng As Range
Sub Dates()
Application.ScreenUpdating = False
Set rngWorksheetNames = Worksheets("info sheet").Range("a1")
dbleDate = Worksheets("front sheet").Range("f13")
Worksheets("info sheet").Activate
Range("a1").Activate
Do Until ActiveCell = ""
strSheet = ActiveCell
Set wsFiltering = Worksheets(strSheet)
intLastRow = wsFiltering.Cells(Rows.Count, "b").End(xlUp).Row
Set rngFilter = wsFiltering.Range("a1:a" & intLastRow)
With rngFilter
.AutoFilter Field:=1, Criteria1:="="
On Error Resume Next
Set rngDates = .Resize(.Rows.Count - 1, 1).Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
With rngDates
.Value = dbleDate
.NumberFormat = "dd/mm/yyyy"
If wsFiltering.FilterMode Then
wsFiltering.ShowAllData
End If
ActiveCell.Offset(1, 0).Select
End With
Application.ScreenUpdating = True
Worksheets("front sheet").Select
MsgBox ("Dates updated")
Loop
You could check existance of data after filtering by using SUBTOTAL formula.
If Application.WorkSheetFunction.Subtotal(103,ActiveSheet.Columns(1)) > 1 Then
'There is data
Else
'There is no data (just header row)
End If
You can read about SUBTOTAL here
Rather than using the Do Until loop, consider using a For Each loop on the Worksheets Collection.
ie.
Sub ForEachWorksheetExample()
Dim sht As Worksheet
'go to error handler if there is an error
On Error GoTo err
'loop through all the worksheets in this workbook
For Each sht In ThisWorkbook.Worksheets
'excute code if the sheet is not the summary page
'and if there is some data in the worksheet (CountA)
'(this may have to be adjusted if you have header rows)
If sht.Name <> "front sheet" And _
Application.WorksheetFunction.CountA(sht.Cells) > 0 Then
'do some stuff in here. Refer to sht as the current worksheet
End If
Next sht
Exit Sub
err:
MsgBox err.Description
End Sub
Also. I would recommend removing the On Error Resume Next statement. It is much better to deal detect and deal with errors rather than ignore them. It could cause strange results.