Delete two rows at the same time by using VBA in a given condition
The condition is that in
Column A, if the cell (
A1,A2,A3....) is a merged cell, then delete the entire row and the row above this cell
I know how to delete one entire row but I duplicate the language when trying to delete the 2nd row (can I put them together?)
Sub test() Dim i As Integer For i = 1 To 300 Step 1 If Cells(i, 1).MergeCells = True Then Rows(i - 1).EntireRow.Delete 'delete the row above the merged cell End If Next i For i = 1 To 300 Step 1 If Cells(i, 1).MergeCells = True Then Rows(i).EntireRow.Delete 'delete another row where the merged cell is End If Next i End Sub
you could try this:
Sub test() Dim i As Long For i = 300 To 1 Step -1 If Cells(i + 1, 1).MergeCells Then Rows(i).Resize(2).EntireRow.Delete 'delete the row with the merged cell and the row above Next If Cells(1, 1).MergeCells Then Rows(1).EntireRow.Delete 'if first cell is merged, then delete its row End Sub
For i = 1 To 300 Step 1 If Cells(i, 1).MergeCells = True Then Cells(i, 1).MergeArea.EntireRow.Delete End If Next
See also questions close to this topic
VLookup error when searching with numbers and text
I am new to VBA and am trying to recode a program that already exists, with the intention of optimizing it and adding new features. The program takes a scanner input (though I am just manually entering in the numbers at the moment), which then records and categorizes the type of item that is taken out. It is then put in a log for reference later. Here is the first Userform that takes the scanned input:
Private Sub TextBox1_Change() Dim barcode As Long, emptyRow As Long, testHold As Long Set TempHold = Worksheets("TempHold") If Application.WorksheetFunction.CountIf(TempHold.Range("D2:D25"), TextBox1.Value) = 1 Then If Application.WorksheetFunction.CountIf(Range("B:B"), TextBox1.Value) = 0 Then CartTypeMenu.Show barcode = TextBox1.Value emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1 Cells(emptyRow, 1).Value = Application.WorksheetFunction.VLookup(barcode, TempHold.Range("D2:E25"), 2, True) Cells(emptyRow, 2).Value = barcode Cells(emptyRow, 3).Value = Format(Now(), "mm/dd/yyyy hh:nn") Cells(emptyRow, 4).Value = CartTypeMenu.ComboBox1.Value TextBox1.Value = "" Else testHold = TextBox1.Value Call boxTest(testHold) End If End If End Sub
I have two tables in a separate sheet (TempHold) that have the scanned input corresponding to a number, and a number corresponding to a name. The row in the final log would basically be the number of the scanned input (as they are labeled by number), the scanned input, the time (which works properly), the type and then the name.
The problem I run into is when I search VLookup for the name to put into the next cell in the log row; getting the name from a number. It only looks for the name if it is actively in the log (it is cleared once tasks are completed). I have tried changing the numbers to strings, and vice versa, but I can't get it to work. Here is the problematic module:
Sub boxTest(testHold As Long) Dim offsetValue As Long, myValue As Variant Set ws = Worksheets("Log") Set sheetLookup = Worksheets("TempHold") offsetValue = Application.Match(testHold, ws.Range("B2:B8"), 0) myValue = InputBox("Enter your number") ws.Range("E" & offsetValue).Value = Application.WorksheetFunction.VLookup(myValue, sheetLookup.Range("A2:B9"), 1, True) End Sub
VLookup keeps giving the error that it can't find the WorksheetFunction in this module.
Extracting the data from each cell If it Matches from List Of values in Excel using VBA
I have the Data like below - CAN RT1278-Aug18 DF4780-Jun18 TAN OTU3219-May18 DTH Fund
My list of values are - CAN CUF DTH RTN TAN ION
I want the solution like, If CAN RT1278-Aug18 compare with the list. It should return the value of CAN. Like wise it should return TAN and DTH.
Macro emailing all but two worksheets
I have a workbook that contains sheets of price lists for different customers, and each week I have to email all the pricelists to the corresponding customers. This is a fairly time-consuming task and I have been trying to automate it with VBA. For the most part, I have succeeded by using Ron de Bruin's code but I have run into an issue that I can't seem to solve so I'm for hoping some insight as to where I've gone wrong.
As previously mentioned this workbook contains multiple, different, price sheets that all need to be sent to different customers. I have modified this code slightly to meet my needs (e.g. only coping visible cells, to include the email signature, etc...). One major change I made to this code is that I loop through a range that contains the recipients' addresses (which can be seen below).
The problem that I'm currently facing is that this code works for all but two sheets. It will create an email for the two problem sheets, but nothing in the range (A1:L85) will be pasted into the email - it just sends an email with no body besides my signature. What makes this worse (or more interesting) is that these two problem sheets occur in the "middle" of the worksheets. Let's say problem sheet 1 = PS_1 and problem sheet 2 = PS_2 it would be like this:
WS_1, WS_2, ..., WS_14, PS_1, WS_16, PS_2, WS_18, ..., WS_32
So I'm wondering why it's only messing up on these two sheets, and how to fix it.
I have included all my code below (except for RangetoHTML which is on Ron de Bruin's website, and a function to that gets the worksheet names):
Sub email() ' this is intended to speed up the code With Excel.Application .ScreenUpdating = False .Calculation = Excel.xlCalculationManual .EnableEvents = False End With Dim OutApp As Object Dim OutMail As Object Dim rng As Range 'this is the range of the price list Dim erng As Range 'this is the range of email addresses Dim cell As Range Dim wsnames() As String 'worksheet names are stored in an array Dim pricedate As String 'the week of prices the user provides (e.g. July 1st - July 7th) Dim tsheets As Integer 'total sheets 'counting variables Dim m As Integer Dim n As Integer Set OutApp = CreateObject("Outlook.Application") 'initializing variables Set rng = Nothing 'initializing variables n = 0 pricedate = InputBox("Enter the week the prices are for (e.g. July 10th - July 15th): ", "Week") If pricedate = vbNullString Then Exit Sub 'if the user presses cancel it will stop the macro tsheets = ActiveWorkbook.Worksheets.Count 'finds how many sheets are in the workbook to adjust the size of the array ReDim wsnames(tsheets) 'resizes the size of the array wsnames = storewsnames 'passing the sheet names to wsnames For m = 1 To tsheets - 1 If wsnames(m) = "Atwood" Then Exit For 'looks for the index of worksheet "Atwood", and once it's found it exits the loop Next m For n = m To tsheets - 1 'sets n to the index of "Atwood" If Sheets(wsnames(n)).Visible = True Then 'only will send emails to visible sheets With Sheets(wsnames(n)) Set rng = .Range("A1:L85") Set erng = .Range("M71:M85") End With On Error GoTo cleanup For Each cell In erng 'searches the cells in the email addresses range If cell.Value Like "?*@?*.?*" Then 'looks '_for email addresses where the email addresses are saved Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .Display .To = "" .CC = "" .BCC = cell.Value .Subject = "CM Weekly Prices - " & wsnames(n) .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri> Hi, " & _ "<br><br>" & "Below are the prices for the week of " & pricedate & _ "." & RangetoHTML(rng) & "Thank you, </BODY><br>" & .HTMLBody .Send End With On Error GoTo cleanup Set OutMail = Nothing End If Next cell End If Next n ' this is intended to speed up the code With Excel.Application .ScreenUpdating = True .Calculation = Excel.xlCalculationAutomatic .EnableEvents = True End With cleanup: Set OutApp = Nothing Application.ScreenUpdating = True End Sub
I'm very unfamiliar with using VBA to send an email so I have been heavily reliant on the code I have used and have tried to only make minor-ish changes.
If there is anything else you folks need, or something is unclear please let me know!
Range.find() correct coding in VBA
I want to find in a column of numbers the first number bigger than some fixed number, say 6.
Please can you tell me what do I need to put in the 'what' argument of the .find function to do that?
If the 'what' argument only accepts single values, how would I code what I want to do?
Subscript out of range error without debug option
I get this code when run my macro : subscript out of range. But i dont have de debug option, only havc 2 options : OK and HELP. 1 time on 20 the macro work perfectly but the rest of time im getting this error. The code make you choose the path you want to search and next the text you want to find in workbook in the path choosen. It search trhought in sub folders too. After that it send back the file name, sheet name, which cell and what text is in the cell.
Can someone help me on that.
Btw, it run the macro but stop and pop that error after the macro search in 4 to 5 differrent files.
Here the code:
Dim AppObject As New Class1 Public WS As Worksheet Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant) Dim myfolder As String Dim a As Single Dim sht As Worksheet Dim Lrow As Single Dim Folders() As String Dim Folder As Variant ReDim Folders(0) Dim wbk As Workbook If IsMissing(Folderpath) Then Set WS = Sheets.Add With Application.FileDialog(msoFileDialogFolderPicker) .Show myfolder = .SelectedItems(1) & "\" End With Str = Application.InputBox(prompt:="Nom de la Personne:", Title:="Personne a chercher", Type:=2) If Str = "" Then Exit Sub WS.Range("A1") = "Semaine" WS.Range("B1") = "Journée" WS.Range("C1") = "Cellule" WS.Range("D1") = "Nom" Folderpath = myfolder Value = Dir(myfolder, &H1F) Else If Right(Folderpath, 2) = "\\" Then Exit Sub End If Value = Dir(Folderpath, &H1F) End If Do Until Value = "" If Value = "." Or Value = ".." Then Else If GetAttr(Folderpath & Value) = 16 Then Folders(UBound(Folders)) = Value ReDim Preserve Folders(UBound(Folders) + 1) ElseIf Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then On Error Resume Next Workbooks.Open Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz" If Err.Number <> 0 Then WS.Range("A4").Offset(a, 0).Value = Value WS.Range("B4").Offset(a, 0).Value = "Password protected" a = a + 1 On Error GoTo 0 Else For Each sht In ActiveWorkbook.Worksheets 'Expand all groups in sheet sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8 Set c = sht.Cells.Find(Str) If Not c Is Nothing Then firstAddress = c.Address Do Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row WS.Range("A1").Offset(Lrow, 0).Value = Value WS.Range("B1").Offset(Lrow, 0).Value = sht.Name WS.Range("C1").Offset(Lrow, 0).Value = c.Address WS.Range("D1").Offset(Lrow, 0).Value = c.Value Set c = sht.Cells.FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If Next sht End If Workbooks(Value).Close False On Error GoTo 0 End If End If Value = Dir Loop For Each Folder In Folders SearchWKBooksSubFolders (Folderpath & Folder & "\") Next Folder Cells.EntireColumn.AutoFit End Sub
thx in advance.
Frequency of occurence for every possible combination of values in two columns on the same row
I have a data-set with Product 1 in Column A and Product 2 in Column B.
I would like to build a new table which counts the number of rows on which every possible combination of Product 1 and Product 2 occur. (Preferably regardless of the order in which they occur, but I can clean that up after if needed)
I can build this manually, however I am dealing with hundreds of possible combinations and would like to automate the process with a macro or any other recommendations anyone has.
Example of raw data:
Product 1 Product 2 Cheese Apple Crackers Sausage Cheese Sausage Crackers Sausage Apple Crackers Apple Cheese Cheese Apple Cherry Apple
Example of new summarized table:
Combo | Count of Combo Occurrences Cheese and Apple | 3 Cheese and Sausage | 1 Cherry and Apple | 1 Crackers and Sausage| 2 Apple and Crackers | 1
Thanks in advance
How to run access query using excel VBA?
I am fairly new to Access and I have been trying for a while to run an Access query and paste the results in Excel using VBA. I have combined some code I found and I think I almost have it but cannot figure out the last step. Here is the code:
Sub test() Dim ws As Worksheet Dim A As Object Dim rs As Object Application.DisplayAlerts = False Set A = CreateObject("Access.Application") Set ws = ThisWorkbook.Sheets("Sheet1") A.Visible = True A.OpenCurrentDatabase ("access database path") A.DoCmd.OpenQuery ("query name") Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset() If Not rs.EOF Then ws.Range("A1").CopyFromRecordset rs End If rs.Close Application.DisplayAlerts = True End Sub
I am trying to run the query and paste the results in cell A1 in sheet 1.
I get a "run time error 3219" for the line:
Set rs = A.CurrentDb().QueryDefs("query name").OpenRecordset()
Any help would be greatly appreciated.