I am using excel to automate data cleaning. I want to create a column called "Group 1". I have another column First Name and another called Last Name. If the first name and last name is empty fill the Group 1 column with yes.
These two worked for me...
Hope this helps, you don't need VB6 for this:
Sub Macro1()
With ActiveWorkbook.Sheets(1):
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To LastRow
If Range("A" & i) = "" Or Range("B" & i) = "" Then
Range("C" & i) = "No"
Else: Range("C" & i) = "Yes"
End If
Next
End With
End Sub
Sub Macro2()
With ActiveWorkbook.Sheets(1):
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("C2").FormulaR1C1 = "=+IF(CONCATENATE(RC[-2]&RC[-1])="""",""Yes"",""No"")"
Range("C2").AutoFill Destination:=Range("C2:C" & LastRow)
End With
End Sub
Related
I am having problems with my code. I am trying to inset values into a "database" by using the find function to identify the correct rownumber. when i run the code the find function returns the next rownumber ie. the serchname is in row 300 but the data is inserted in row 301.
the code i am using is as follows:
For Each Cell In Workbooks(controlfile).Sheets("Lab").Range("B9:B56")
If Cell.Value <> "" Then
'Range("N" & latestRow).Value = Right(DataArray(1), 4) & Right(DataArray(2), 4)
'Range("N" & latestRow).NumberFormat = "00000000"
søgeOrd = Right(Cell.Value, 4) & Right(Cell.Offset(0, 1), 4)
Workbooks(controlfile).Sheets("Lab").Range("A1").Value = søgeOrd
Workbooks(controlfile).Sheets("Lab").Range("A1").NumberFormat = "00000000"
LinjeL = Cell.Row
FGM = Workbooks(controlfile).Sheets("Lab").Range("F" & LinjeL).Value
STA = Workbooks(controlfile).Sheets("Lab").Range("I" & LinjeL).Value
BMK = Workbooks(controlfile).Sheets("Lab").Range("J" & LinjeL).Value
VK = Workbooks(controlfile).Sheets("Lab").Range("L" & LinjeL).Value
DP = Workbooks(controlfile).Sheets("Lab").Range("M" & LinjeL).Value
SNB = Workbooks(controlfile).Sheets("Lab").Range("N" & LinjeL).Value
Workbooks(controlfile).Sheets("Lab").Range("A1").ClearContents
'find søgeord i database og indsæt de værdier som er fundet i lab
Workbooks(FileName).Sheets("Database").Activate
Columns("N:N").Select
Set cellD = Selection.Find(What:=Workbooks(controlfile).Sheets("Lab").Range("A1").Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cellD Is Nothing Then LinjeD = cellD.Row
If Range("E" & LinjeD).Value <> "" Then
'kopier alle data til fejllog hvis der allerede er data
Range("A" & LinjeD).Select
ActiveCell.EntireRow.Copy
Workbooks(FileName).Worksheets("Fejllog").Activate
LastLine = Workbooks(FileName).Sheets("Fejllog").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Range("A" & LastLine).PasteSpecial
Application.CutCopyMode = False
Workbooks(FileName).Sheets("Database").Activate
Range("E" & LinjeD).Value = FGM
Range("H" & LinjeD).Value = STA
Range("I" & LinjeD).Value = BMK
Range("O" & LinjeD).Value = Format(Now, "dd.mm.yyyy")
Range("P" & LinjeD).Value = VK
Range("Q" & LinjeD).Value = DP
Range("R" & LinjeD).Value = SNB
Workbooks(controlfile).Sheets("Lab").Activate
Else
Range("E" & LinjeD).Value = FGM
Range("H" & LinjeD).Value = STA
Range("I" & LinjeD).Value = BMK
Range("O" & LinjeD).Value = Format(Now, "dd.mm.yyyy")
Range("P" & LinjeD).Value = VK
Range("Q" & LinjeD).Value = DP
Range("R" & LinjeD).Value = SNB
Workbooks(controlfile).Sheets("Lab").Activate
End If
End If
Next Cell
Any input would be greatly appreciated, thank you.
I re-wrote your code to eliminate use of the Selection object.
Private Sub Snippet()
Dim WsDb As Worksheet
Dim ClmN As Range
Dim cellID As Range
Dim What As Variant
Dim LineID As Long
What = Workbooks(controlfile).Sheets("Lab").Range("A1").Value
Set WsDb = Workbooks(Filename).Sheets("Database")
Set ClmN = WsDb.Columns("N:N")
Set cellD = ClmN.Find(What:=What, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cellD Is Nothing Then LinjeD = cellD.Row
End Sub
Observe how the definition of the worksheet on which you do your search is now done by declaring a variable for it. The code will now work smoothly in the background without screen flickering.
Now you can blame me for destroying your reference to the ActiveCell. Did I really? Which cell was active in your code when the Database tab was activated? Could have been anyone or none. Now the code will crash because the ActiveCell isn't in the ClmN range. Obviously, you need to specify a cell in that range for starting the search.
Does the cellID range start in a row other than where What was found? I doubt it and you don't claim so, either. You say that a row gets inserted at a point other than LineID. That is normal and has to do with the action of inserting a row, not related to the code you published. Logically, the new row should take the place of the one you specified. Therefore the cellId.Row would now be one row lower than before. However, I got this wrong many times. Therefore I always test which row is the old and which one the new. It's not difficult - and it's always the same.
I have found the solution.
I had mistakenly cleared the content of the cell used as the search name before the search began. this resulted in a search for an empty cell.
Thank you to all of you for making inputs, and helping me clean up my code :)
It is amazing how you can spend hours looking at something, only to find the answer is right in front of you.
I have below code which will help me to do some formatting. but i want increase the efficiency of the code by reducing the time. Below are the formatting steps which macro will be doing.
Convert "Q" and "S" column" to number format.
Replicate the "I" column to new column by inserting column next to it.
Cut the Column "AD" and paste to column "O".
Remove columns ("A:A,AD:AG")
Replace "#" with null and "OUT" with P input value in "AC" column.
Round the "Q" and "S" column numbers to 2 decimal.
Change the sign of values in column Q by multiplying -1(*-1)
Filter on "Q" column with "0" and filter on "S" column with "0". Then
remove those rows with "Q" and "S" is Zero.
Filter 0 on Q column, Clear only visible cells of "Q" and "R" Columns.
Filter 0 on "S" column, Clear only visible cells of "S" and "T" Columns.
Copy the headers (ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy) and
paste to the A1 of file formatted.
Remove all columns and rows which doesn’t have data apart from used
range.
Currently macro working fine but taking some time.As i am new to VBA not sure how to optimize the code. Hence i here looking for help from experts. Thanks in advance.
Below is the code
Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim Lastcol As Long
Dim P As String
'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
'Makes sure the user can select only one file
.AllowMultiSelect = True
'Filter to just the following types of files to narrow down selection options
'.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
'It's a good idea to still check if the file type selected is accurate.
'Quit the procedure if the user didn't select the type of file we need.
If InStr(fullpath, ".xls") = 0 Then
If InStr(fullpath, ".csv") = 0 Then
Exit Sub
End If
End If
'Open the file selected by the user
Workbooks.Open fullpath
P = InputBox("Please Enter the Version")
Application.ScreenUpdating = False
With ActiveWorkbook
Columns(17).NumberFormat = "0"
Columns(19).NumberFormat = "0"
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("I").Copy
Columns("I").Insert Shift:=xlToRight
'Range("AE2").Value = P
'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Columns("AE").Copy
Columns("P").PasteSpecial xlPasteValues
ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("AD2").Formula = "=Round(Q2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=Round(S2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("S2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=(Q2*-1)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Columns("AD:AD").EntireColumn.Delete
With ActiveSheet.Range("A:AC")
.AutoFilter Field:=17, Criteria1:="0"
.AutoFilter Field:=19, Criteria1:="0"
.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
.AutoFilter Field:=17, Criteria1:="0"
.Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.AutoFilter Field:=19, Criteria1:="0"
.Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
'.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Farmatting"
End Sub
This isn't a site for reviewing code. There is another one, especially for that purpose in the StackOverflow family. I nevertheless reviewed your code and found nothing that I might point to to make it slow in particular. There should be ways to do the job faster but they require knowledge of your intentions. It seems you have a big worksheet. So it may take a little time but not enough to have a coffee. My comments, therefore, focus on the code's inherent imprecision which makes it prone to crash as well as prone to do untold damage if it's let lose on the wrong worksheet. I have added comments.
Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim LastCol As Long
Dim P As String
' Display a Dialog Box that allows to select a single file.
' The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
' Makes sure the user can select only one file - quite the opposite
.AllowMultiSelect = True
'Filter to just the following types of files to narrow down selection options
'.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
' It's a good idea to still check if the file type selected is accurate.
If InStr(fullpath, ".xls") = 0 Or InStr(fullpath, ".csv") = 0 Then
' Quit the procedure if the user didn't select the type of file we need.
Exit Sub
End If
'Open the file selected by the user
Workbooks.Open fullpath
P = InputBox("Please Enter the Version")
Application.ScreenUpdating = False
With ActiveWorkbook
' There isn't a single reference to the ActiveWorkbook
' in the entire 'With' bracket.
' Create a link to the 'With' object by a leading period.
' Example:-
' With .Worksheets(1) ' linked to ActiveWorkbook
' ' below, both cells and Rows.Count of Worksheets(1)
' LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
' End With
' which sheet are you working on here?
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns(17).NumberFormat = "0"
Columns(19).NumberFormat = "0"
Columns("I").Copy
Columns("I").Insert Shift:=xlToRight
'Range("AE2").Value = P
'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Columns("AE").Copy
Columns("P").PasteSpecial xlPasteValues
' You didn't activate any sheet
ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
' everything you do above or below this line
'' is done to the ActiveSheet
Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
' This should probably be done using a cell format.
' If you need rounded values in later calculations do
' the rounding in later calculations, not in the original data.
Range("AD2").Formula = "=Round(Q2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=Round(S2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("S2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=(Q2*-1)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Columns("AD:AD").EntireColumn.Delete
End With
With ActiveSheet.Range("A:AC")
' This method will throw an error if there are no visible cells
' why not suppress the display of zero with a CellFormat?
.AutoFilter Field:=17, Criteria1:="0"
.AutoFilter Field:=19, Criteria1:="0"
.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
.AutoFilter Field:=17, Criteria1:="0"
.Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.AutoFilter Field:=19, Criteria1:="0"
.Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
'.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
' you are still working on the undefined ActiveSheet
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Formatting"
End Sub
Below code helps me out, if on sheet1, specific date on column L is less than or equal to today's date, from sheet1 copy specific rows to sheet2 starting with A3 and do it for the whole list.
I have two follow up questions;
I want copied cells on sheet2 to be inserted on a newly created row ( need to incorporate End(xlUp) ) . Couldn't figure out yet
For some reason code doesn't work if my first sheet have filters on... I have to remove filters for the code. Not sure why it is not working regardless of filters on or off.
Sub CopyRange()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
Range("L1:L" & LastRow).AutoFilter Field:=1, Criteria1:="<=" & Date
Intersect(Rows("2:" & LastRow),
Range("A:A,F:H,K:L,R:R,U:U").SpecialCells(xlCellTypeVisible)).Copy
Sheets("Sheet2").Cells(3, 1)
Range("L1").AutoFilter
Application.ScreenUpdating = True
End Sub
Just use Range("L:L"). Also, I would suggest you use With ActiveSheet or better yet With Worksheet("sheetname")
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With Worksheets("Sheet1")
Range("L:L").AutoFilter Field:=1, Criteria1:="<=" & Date
Intersect(Rows("2:" & LastRow), _
Range("A:A,F:H,K:L,R:R,U:U").SpecialCells(xlCellTypeVisible)).Copy _
Sheets("Sheet2").Cells(3, 1)
Range("L1").AutoFilter
End With
Application.ScreenUpdating = True
I know how to find the last row, and add a SUM() to that, but how do I SUM(G+H) in column O for each row of the used range?
I would use this to get the last row and sum columns, how could this be converted to sum rows?
With ws
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
.Range("C" & LastRow + 1).FormulaR1C1 = "=SUM(R[-" & LastRow & "]C:R[-1]C)"
.Range("C" & LastRow + 1 & ":M" & LastRow + 1).FillRight
End With
Something like this would get G + H in column O:
Sub testme()
Dim l_counter As Long
For l_counter = 1 To 100
ActiveSheet.Cells(l_counter, 15).FormulaR1C1 = "=RC7+RC8"
Next l_counter
End Sub
Just make sure that you change the 100 to a variable, in your case, LastRow
I have dataset from columns A to K and would like find duplicate rows of data from columns A, D, F, J and K.
I have the following code:
Sub RemoveDupes2()
Dim r As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
With Range("L2:L" & lr)
.Formula = "=ROW()"
.Value = .Value
End With
Range("A2:L" & lr).Sort Key1:=Range("A2"), Order1:=1, Key2:=Range("B2"), Order2:=1
With Range("M2:M" & lr)
.FormulaR1C1 = "=RC[-12]&RC[-11]&RC[-6]&RC[-4]&RC[-2]"
.Value = .Value
End With
With Range("N2:N" & lr)
.FormulaR1C1 = "=COUNTIF(R1C13:RC[-1],RC[-1])"
.Value = .Value
End With
For r = lr To 2 Step -1
If Cells(r, 14).Value > 2 Then
Rows(r).Delete
ElseIf Cells(r, 14).Value = 2 Then
Cells(r - 1, 1).Resize(, 7).Font.Bold = True
Rows(r).Delete
End If
Next r
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Range("A2:L" & lr).Sort Key1:=Range("L2"), Order1:=1
Range("L2:N" & lr).ClearContents
Application.ScreenUpdating = True
End Sub
The code currently deletes the entire data set and I am not sure why its doing so, as I am novice user to VBA.
https://www.dropbox.com/s/otgkk1igcd2995t/duplicates.xlsx
In your first With, please try changing:
.FormulaR1C1 = "=RC[-12]&RC[-11]&RC[-6]&RC[-4]&RC[-2]"
to
.FormulaR1C1 = "=RC[-12]&RC[-9]&RC[-7]&RC[-3]&RC[-2]"
There may well however be a separate issue because even unaltered the above code does not delete the entire dataset (for me, with Excel 2007).