I have an Access function built to export a query to Excel. There are spaces for 15 results. Not all of them are used though, so I'd like to delete the blank columns.
I've been trying to search Lrow + 1 for "0.000" and then deleting the entire column, but it isn't working. 0.000 is a formula but I am using .Value method so that shouldn't be the problem, right?
Here's the code I tried to write (but failed miserably):
For Each Cel In wks.Range("C" & Lrow + 1, "V" & Lrow + 1)
If Cel.Value = "0.000" Then
Cel.EntireColumn.Delete
Cel.Offset(0, 1).EntireColumn.Delete
End If
Next Cel
As in the picture, there are 2 results shown. This is what I would like to happen: Search lrow + 1 (the row with 0.000), delete those columns along with the column next to it.
Any help would be appreciated.
A few issues here:
The range reference is wrong as Big Ben pointed out
The comparison is (probably) wrong. I'm guessing the call values are numbers, not strings that look like numbers. So comparing 0 to "0.000" will fail. Use = 0 or if you are worried about small not quite 0 numbers use Absolute value <= 0.0005
The delete logic is flawed, it won't delete the columns you think
.
Set rng = wks.Range("C" & Lrow + 1 & ":V" & Lrow + 1)
For i = rng.Columns.Count To 1 Step -1
If rng.Cells(1, i).HasFormula Then
If Abs(rng.Cells(1, i)) <= 0.0005 Then
Rng.Cells(1, i).Resize(1, 2).EntireColumn.Delete
End If
End If
Next
Don't forget to use Option Explicit and declare all variables
Related
I have two cells that are refusing to populate in row 10 and 70. Every other cell populates and I have tried changing columns, even workbooks but I still get the same problem. There is no protection or passwords. I have no idea of the cause. This is the very simple code it is running on these cells:
i = 1
Worksheets("Output").Range("N1") = i
For z = 2 To lastrow - 1
If Worksheets("Output").Range("D" & z).Value < Worksheets("Output").Range("D" & z - 1).Value Then
i = i + 1
Worksheets("Output").Range("N" & z).Value = i
End If
If Worksheets("Output").Range("D" & z).Value = Worksheets("Output").Range("D" & z - 1).Value Then
Worksheets("Output").Range("N" & z).Value = i & " (tie)"
Worksheets("Output").Range("N" & z - 1).Value = i & " (tie)"
End If
If Worksheets("Output").Range("D" & z).Value = "" Then
i = i + 1
Worksheets("Output").Range("N" & z).Value = i
End If
Next z
I cannot fathom out why it is happening, the trouble is it messes up my sequence. I have tried forcing it to populate if it is blank with those last 3 lines but still nothing.
The principle error in your code is that it contains a logical trap:-
If [Condition 1] Then i = i + 1
If [Condition 2] Then i = i + 1
This is contrary to the logic that every row defined by z needs a result. The trap is in that nothing will be counted if neither of the two conditions are met. Therefore you should structure your code as follows.
If [Condition 1] Then
i = i + 1
ElseIf [Condition 2] Then
i = i + 1
Else
i = i - 1
End If
In this way, using Else, it will be impossible to skip a row.
However, there are more logical flaws in your code. and once I set out to determine what might be in column D I came to a totally different structure which I share with you below.
Sub STO_66111404()
Dim i As Long ' rank
Dim Tie As Boolean ' next item is of same value
Dim Tied As Boolean ' last item was of same value
Dim R As Long ' loop counter: rows
With Worksheets("Output")
For R = 1 To .Cells(.Rows.Count, "D").End(xlUp).Row - 1
i = i + Abs(Not Tie) ' Abs(Not Tie) = 1 if Tie is False
' Val() converts any non-numeric value, incl "", to 0
Tied = Tie
Tie = Val(.Cells(R, "D").Value) = Val(.Cells(R + 1, "D").Value)
.Cells(R, "N").Value = i & IIf(Tie Or Tied, " (tie)", "")
Next R
.Cells(R, "N").Value = i + Abs(Not Tie) & IIf(Tie, " (tie)", "")
End With
End Sub
It may take you a moment to recognize this code as your own. So, here are a few points to guide you.
With Worksheets("Output") helps you avoid repeating the sheet name over and over again. In the code that follows this line, and until End With, the object is represented merely by a leading period. .Cells(.Rows.Count, "D") stands for Worksheets("Output").Cells(Worksheets("Output").Rows.Count, "D")
Ranges comprising of single cells are most efficiently addressed by the syntax designed for that purpose, to wit, by a cell's coordinates instead of its range name. So, .Cells(R, "D") stands for Range("D" & R). This syntax has the added advantage that it is also equal to .Cells(R, 4), meaning you can easily calculate both row and column numbers.
The big difference in the approach is that your code focuses on the conditions and therefore uses a lot of IFs. In the above approach the focus is on the results of the conditions, expressed in the two variables, Tie and Tied. Your code has no equivalent for the latter but doesn't seem to need it, either. Note, however, that the above code may not handle the case correctly where the next value in column D is smaller than the preceding. The code just checks for equality and presumes that the next value is bigger if it isn't equal, setting Tie = False here: Tie = Val(.Cells(R, "D").Value) = Val(.Cells(R + 1, "D").Value). In your approach, this may be the reason for the skipped lines.
I am trying to create a Module that will format an excel spreadsheet for my team at work. There is one column that will contain the word "CPT" and various CPT codes with descriptions.
I need to delete all text (CPT description) after the 5 digit CPT code but alsp keep the word CPT in other cells.
For example: Column S, Row 6 contains only the word "CPT" (not in quotations)
Then Column S, Row 7 contains the text "99217 Observation Care Discharge"
This setup repeats several times throughout Column S.
I would like for Row 6 to stay the same as it is ("CPT") but in Row 7 i only want to keep "99217"
Unfortunately, this is not possible to do by hand as there are several people who will need this macro and our spreadsheets can have this wording repeated hundreds of times in this column with different CPT codes and descriptions.
I have tried various If/Then statements, If/Then/Else
Sub CPTcolumn()
Dim celltxt As String
celltxt = ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Dim LR As Long, i As Long
LR = Range("S6" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
Else
With Range("S6" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
Next i
End If
End Sub
When i try to run it I get Various "Compile Errors"
I would do this differently.
Given:
The cell to be modified will be the cell under a cell that contains CPT
in the algorithm below, we look for CPT all caps and only that contents. Easily modified if that is not the case.
Since you write " a five digit code", we need only extract the first five characters.
IF you might have some cells that contain CPT where the cell underneath does not contain a CPT code, then we'd also have to check the contents of the cell beneath to see if it looked like a CPT code.
So we just use the Range.Find method:
Sub CPT()
Dim WS As Worksheet, R As Range, C As Range
Dim sfirstAddress As String
Set WS = Worksheets("sheet4")
With WS.Cells
Set R = .Find(what:="CPT", LookIn:=xlValues, lookat:=xlWhole, _
MatchCase:=True)
If Not R Is Nothing Then
sfirstAddress = R.Address
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
Do
Set R = .FindNext(R)
If Not R.Address = sfirstAddress Then
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
End If
Loop Until R.Address = sfirstAddress
End If
End With
End Sub
If this sequence is guaranteed to only be in Column S, we can change
With WS.Cells
to With WS.Columns(19).Cells
and that might speed things up a bit.
You may also speed things up by adding turning off ScreenUpdating and Calculation while this runs.
Your first error will occur here:
ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Because you're trying to retrieve text from the last used range starting .End(xlUp) at Range("S61048576"), which is roughly 58 times the row limit in Excel. You might change Range("S6" & Rows.Count) to Range("S" & Rows.Count)
Your second error will occur here:
LR = Range("S6" & Rows.Count).End(xlUp).Row
Which will be the same error.
The third error will occur here:
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
You cannot nest half of an If-End If block in a For-Next loop, or vice-versa and you've done both. If you want to iterate and perform an If-End If each iteration, you need to contain the If-End If within the For-Next like
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
'Is the purpose here to do nothing???
Else
With Range("S" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
End If
Next i
EDIT:
For technical accuracy, your first error would actually be your broken up For-Next and If-End If, as you wouldn't even be able to compile to execute the code to run into the other two errors.
You can simply use the Mid function in the worksheet.
As I understood from your question that you need to separate numbers and put them in other cells, is this true?
To do this, you can write this function in cell R6 like this
=Mid(S6,1,5)
Then press enter and drag the function down and you will find that all the cells containing numbers and texts have been retained numbers in them
At work I have a repetitive task of going through a list of account activity and changes where I have to delete blank spaces and lines that are not necessary for the maintenance I perform. For 80% of the these I am able to work a for each loop that is pretty inelegant but effective.
Example:
For Each c In ActiveSheet.UsedRange
If InStr(1, c.Value, SubString7) = 1 Then ' find earn lines and remove
c.EntireRow.Offset(1).Delete
c.EntireRow.Clear
c.EntireRow.Offset(-1).Delete
End If
Next
The substring is the descriptive title line for each type of transaction. The one I am having trouble with is variable, while the others are not. It can be 9 lines long or 6 lines long, and could also be positive or negative but each possibility comes with the same title line.
Based on everything I could find to try to figure it out, I need to use a loop, moving from bottom to top. I cannot get it to trigger with either InStr, nor left/right.
This is a cut down version of what I am trying now:
lr = Range("A" & Rows.Count).End(xlUp).Row
For rowcounter = lr To 0 Step -1
If VBA.Strings.Left(Cells(rowcounter).Value, 11) Like "Earn Manual" Then
If VBA.Strings.Left(Cells(rowcounter + 5).Value, 1) = "-" Then
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'this, several more times with different offsets for the required lines
Else
Cells(rowcounter).EntireRow.Offset(5).Delete 'different ones, finalizing removals on the negative value items
End if
Else
If VBA.Strings.Left(Cells(rowcounter + 6).Value, 3) = "AVG" Then
Cells(rowcounter).EntireRow.Offset(5).Delete 'again, but with different offsets
Else 'There is one line for these that I have to split into two lines, not sure if this will even work as I cannot get it to trigger
Cells(rowcounter).EntireRow.Offset(8).Delete
Cells(rowcounter).EntireRow.Offset(7).Delete
Cells(rowcounter + 4).Value = VBA.Strings.Right(Cells(rowcounter + 3).Value, 25)
Cells(rowcounter + 3).Value = VBA.Strings.Left(Cells(rowcounter + 3).Value, 13)
End if
End If
End If
Next Rowcounter
I had originally had that first If line as:
If InStr(1, Cells(rowcounter).Value, SubString8) = 1 Then
I tried switching to Left() and Like but still no dice.
Attempting to provide sample of input/output
sample data:
Goal output from column A:
Retained Data
Update again, new and improved code that is still failing:
Next
For i = 1 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
If ws.Range("A" & i) Like "Earn Manual*" Then
If ws.c("A" & i + 5) Like "-*" Then
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 8) ' shows AVG, negative value
Else
Set Deleteme = c.Range("A" & i, "A" & i + 5) ' no AVG, negative value
End If
Else
If ws.c("A" & i + 6) Like "Avg*" Then
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
Else
Set Deleteme = c.Range("A" & i, "A" & i + 3)
Set Deleteme = c.Range("A" & i + 5)
End If
End If
Else
Set Deleteme = Union(Deleteme, ws.Range("A" & i))
End If
Next A
There is no way that I can get this 100% correct because it was based of the OP's new and improve code, which has some flaws in its logic. My goal was to simply the overall syntax to make it easier to get right.
The problem with deletion with offset values is that the values move on you. My solution is to Union all rows to be deleted and delete them then after the loop is done. This is not only more efficient but it allows us to loop from top to bottom. This makes the code it much easier to follow.
When Union ranges in this way, you must first test to see if the target range to be deleted is Nothing. If the target range is Nothing, we Set it to the new range else we Union the two ranges. I wrote a subroutine UnionRange(), so that we would not have to repeat this process each time we needed to do a Union.
With blocks, Range.Offset() and Range.Resize() were used to simply the syntax. I feel like this is cleaner than concatenating addresses inside of a range (e.g. Range("A" & i + 5) and Range("A" & i, "A" & i + 8)).
Sub CleanUp()
With ThisWorkbook.Worksheets("Sheet1")
Dim r As Long
Dim rUnion As Range
For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
With .Cells(r, 1)
If .Value = "" Then
UnionRange rUnion, .Offset(0)
ElseIf .Value Like "Earn Manual*" Then
If .Offset(6).Value Like "Avg*" Then ' shows AVG, negative value
UnionRange rUnion, .Offset(8)
Else ' no AVG, negative value
UnionRange rUnion, .Offset(5)
End If
Else
'This can't be right
If .Offset(6).Value Like "Avg*" Then 'If Like "Avg*" Then Delete These Cells
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
Else 'Hell If Not Like "Avg*" Then Delete The Same Cells Anyway
UnionRange rUnion, .Resize(3)
UnionRange rUnion, .Offset(5)
End If
End If
End With
Next
End With
If Not rUnion Is Nothing Then
Application.ScreenUpdating = False
rUnion.EntireRow.Delete
End If
End Sub
Sub UnionRange(ByRef rUnion As Range, ByRef Cell As Range)
If rUnion Is Nothing Then
Set rUnion = Cell
Else
Set rUnion = Union(rUnion, Cell)
End If
End Sub
I have a data set with Names and Addresses in an Excel file in following format.
Name1
134/47/1,
adrs1, adr2, country
Name2
adrs1, adrs2, country
Name3
107/c,
adrs3, adrs3, country
etc…
I want to split these data into multiple rows in following format
Name1
134/47/1,
adrs1,
adrs2,
country
Name2
No 134/63,
adrs1,
adrs2,
country
etc…
I tried following but it worked for one row cell only.
Sub tst()
Dim X As Variant
X = Split(Range("A1").Value, ",")
Range("A1").Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End Sub
The following macro might help you. You would have to select the very last cell in your table containing a multipart address. When you start the macro it will then work its way up to the top and insert address lines where needed (only in the current column) and then exit.
Option Base 1
Sub trnsfrm()
Dim i%, n%, ret(3, 1)
Set r = Selection
Do
a = Split(r, ",")
ret(1, 1) = Trim(a(0))
ret(2, 1) = Trim(a(1))
ret(3, 1) = Trim(a(2))
r.Range([a2], [a3]).Insert Shift:=xlDown
r.Range([a1], [a3]) = ret
If r.Row <= 4 Then Exit Do
Set r = r.Offset(-4)
Loop
End Sub
If you want to insert lines across the whole table you should replace the line (10)
r.Range([a2], [a3]).Insert Shift:=xlDown
by
r.Range([a2], [a3]).EntireRow.Insert Shift:=xlDown
Assumptions / Warning
Since the macro will actually change your current table and 'undo' does not work with macros you should definitely save everything before you try it.
The macro assumes that each address block consists of exactly 4 lines. If there are fewer or more lines to an address the maro will get out of sync and will very likely output garbage or halt.
I'm not sure whether your sample data had trailing commas on single values as a typo or if that is what accurately represents your data but that should be accounted for. A rogue comma as a suffix will create an extra element to the variant array thereby throwing off dimensions created by referencing the UBound function.
Sub split_from_below_space()
Dim rw As Long, v As Long, vVALs As Variant
With Worksheets("Sheet1") 'set this worksheet reference properly!
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
.Cells(rw, 1) = Trim(.Cells(rw, 1).Value2)
If CBool(InStr(1, .Cells(rw, 1).Value2, Chr(44) & Chr(32))) Then
vVALs = Split(.Cells(rw, 1).Value2, Chr(44) & Chr(32))
.Cells(rw + 1, 1).Resize(UBound(vVALs), 1).EntireRow.Insert
.Cells(rw, 1).Resize(UBound(vVALs) + 1, 1) = _
Application.Transpose(vVALs)
For v = UBound(vVALs) - 1 To LBound(vVALs) Step -1
.Cells(rw, 1).Offset(v, 0) = _
Trim(.Cells(rw, 1).Offset(v, 0).Value2) & Chr(44)
Next v
End If
Next rw
End With
End Sub
You will need to insert rows to accommodate the data and that method is almost always (as in this case) better performed by working from the bottom to the top.
We have a blank workbook which I would like the user to be able to paste a list of reference numbers into column A. Some of these reference numbers will have a "+" at the end.
Sub texter1()
With Sheets("texter")
ll = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 1 To ll
If InStr(1, .Range("a" & i).Value, "+", 1) Then
.Range("b" & i).Formula = "=LEFT(A" & i & ", LEN(A" & i & ")-1)"
.Range("c" & i).Value = Sheets("texter").Range("b" & i).Value
.Range("d" & i).Formula = "=VLOOKUP($c" & i & ", _
[Current_Master.xlsm]Master!$A$3:$BB$20000,14,FALSE)"
.Range("e" & i).Formula = "=VLOOKUP($c" & i & ", _
[Current_Master.xlsm]Master!$A$3:$BB$20000,15,FALSE)"
Else
Cells(i, "a").EntireRow.Delete
End If
Next i
End With
End Sub
I would like reference numbers without the "+" to have the whole row deleted. Reference numbers with a "+" work fine.
this seems to work but has to be run multiple times for it to delete all the rows without a "+" and I cannot figure out why. Please help
Thank you
You cannot delete a row inside a loop as far as affects the iterations. Imagine this: you have 4 rows; the second row meets the conditions and is deleted; in the next iteration the counter is 3 but the row number 3 is now the fourth row (when you delete a row, all the ones below go up one position); consequently, row number 3 wouldn't be analysed. Thus the solution is simple:
Cells(i, "a").EntireRow.Clear()
If you want to actually delete the whole row, you would have to do it outside the main loop. For example: store all the rows to be deleted in an array and iterate through this array right after completing the main loop.
Another alternative would be performing the iterations in the main loop in inverse order (from maximum row to minimum one), although this option is not always applicable (not sure if in your case) and might provoke further problems. The two options above are good enough, I have mentioned this last alternative just as something worthy to be known.
--- UPDATE
To delete the rows after the main loop you can use something on these lines:
'Declaration of variables
ReDim allRows(ll + 1) As Long
Dim allRowsCount As Long: allRowsCount = 0
In your main loop you store the given rows (where you have now Cells(i, "a").EntireRow.Delete):
For i = 1 To ll
'etc.
else
allRowsCount = allRowsCount + 1
allRows(allRowsCount) = i
After the loop is completed, you go through all the stored rows (in inverse order) and delete them:
If (allRowsCount > 0) Then
Dim curRow As Long: curRow = allRowsCount + 1
Do
curRow = curRow - 1
.Rows(allRows(curRow)).Delete
Loop While (curRow > 1)
End If
End With
End Sub