I'm new to VBA and not very adept with the programming so I'm hoping for some help here.
Here's the thing:
I have an excel sheet where I need to scan the entire rows and delete rows where Column C and Column D have the text "NA" in the same row.
Thanks in advance.
Here is something I've used before. This applies filters, filters for NA in both column C and D, then removes those rows (excluding the header). Note that this will only remove the row if NA is in BOTH columns. If NA is in C but not in D then it will not remove the row.
'Applies filter to the columns. You will want to adjust your range.
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$6").AutoFilter Field:=3, Criteria1:="NA"
ActiveSheet.Range("$A$1:$D$6").AutoFilter Field:=4, Criteria1:="NA"
'Removes the rows that are displayed, except the header
Application.DisplayAlerts = False
ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
Application.DisplayAlerts = True
'Removes the filter
Cells.Select
Selection.AutoFilter
Hope that helps.
Try this. You need to start loop from the end :
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("sh_test") 'edit your sheet name
Dim lastrow As Long
lastrow = ws.Range("C" & Rows.Count).End(xlUp).Row + 1 'maybe change letter of the column
For i = lastrow To 2 Step -1
If ws.Cells(i, 3).Value = "NA" And ws.Cells(i, 4).Value = "NA" Then
ws.Rows(i).EntireRow.Delete
End If
Next i
End Sub
Related
Sub retrieve()
Dim r As Long, endrow As Long, pasterowindex As Long, Cells() As String, Columns As Range
Sheets("Raw Trade Log").Range("A4").Select
Selection.End(xlDown).Select: endrow = ActiveCell.Row
pasterowindex = 1
For r = 4 To endrow
If Cells(r, Columns(17).Value = "Y") Then
Rows(r).Select
Selection.Copy
Sheets("Completed Trade log").Select
Rows(pasterowindex).Select
ActiveSheet.Paste
pasterowindex = pasterowindex + 1
Sheets("Raw Trade Log").Select
End If
Next r
End Sub
I am trying to tell vba to automatically copy the whole row to another sheet when value in a column becomes "Y" however I keep getting
Run time error '91'
from If Cells(r, Columns(17).Value = "Y") Then and I have not idea how to fix it, can someone kindly let me know where did I made a mistake?
The error is mainly because of the Select and the Activate words. These are really not programming-friendly and one should be careful around them. Thus, the best way is to avoid them completely - How to avoid using Select in Excel VBA.
Concerning the task "How to copy rows under some condition to another worksheet" this is a small example, without the Select and Activate:
Sub TestMe()
Dim wksTarget As Worksheet: Set wksTarget = Worksheets(1)
Dim wksSource As Worksheet: Set wksSource = Worksheets(2)
Dim r As Long
For r = 4 To 50
If wksSource.Cells(r, "A") = "y" Then
wksSource.Rows(r).Copy Destination:=wksTarget.Rows(r)
End If
Next r
End Sub
the 50 is hardcoded, it can be referred as a variable as well;
the code checks for the word y in column A, but it can be changed by changing the A in If wksSource.Cells(r, "A") to something corresponding.
you could use AutoFilter():
Sub retrieve()
With Sheets("Raw Trade Log") 'reference your "source" sheet
With .Range("A3", .Cells(.Rows.Count, 1).End(xlDown)).Offset(, 16) ' reference referenced sheet column Q cells from row 3 (header) down to column A last not empty row
.AutoFilter Field:=1, Criteria1:="y" ' filtere referenced column with "y" content
If Application.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Completed Trade log").Range("A1") ' if any filtered cell other than header, copy filtered cells entire row to "target" sheet
End With
.AutoFilterMode = False
End With
End Sub
I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function
I have a table with 2 columns.
A B
A2 B2 nn
A3 B3 nn
.....
An Bn nn
I need to copy the content of B2 cell and paste it to all the other B column cells, where A column has a value.
Then to find a certain value (nn) in B column and substitute it with A column value.
In order to copy B2 content I do this:
Sub CopyTest()
'ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
Range("B3:B1048576").Select
Selection.ClearContents
Range("B2").Copy
Range("B2:B7").PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End Sub
1.The problem is that I don't know how to do a paste not till certain cell (B7), but for all the table (so till A column contains value).
Similar problem I have substituting certain B column value with a value from column A.
Sub ReplaceExample()
Dim OriginalText As String
Dim CorrectedText As String
OriginalText = Range("B2").Value
CorrectedText = Replace(OriginalText, "E_ONBAL", Range("A2").Value)
Range("B2").Offset(, 1).Value = CorrectedText
End Sub
2.How to do the same action for all the A column, so to do kind of loop?
Thanks!
The first part is managed, so I publish the answer, in case it will be useful for someone:
Sub CopyTest()
Range("B3:B1048576").Select
Selection.ClearContents
Set currentsheet = ThisWorkbook.Worksheets("Sheet1")
LastRow = currentsheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("B2").Copy
Range("B3" & ":" & "B" & LastRow).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End Sub
I just still did not manage how to modify second part of the script with substitution in order to do the same action for all the A column, so to do kind of loop.
This example how to copy from activesheet to another sheet.
Sub Test1()
Dim SuccessSheet As String
Application.ScreenUpdating = False
SuccessSheet = ActiveSheet.Name
WS_Count = ActiveWorkbook.Worksheets.Count
' Generate new sheet if it does not exist
If Not sheetExists(SuccessSheet & " Log") Then
Set WS = Sheets.Add(After:=Worksheets(WS_Count))
Worksheets(SuccessSheet).Columns(2).Copy Destination:=Worksheets(WS.Name).Columns(2)
Worksheets(SuccessSheet).Columns(4).Copy Destination:=Worksheets(WS.Name).Columns(1)
WS.Name = SuccessSheet & " Log"
End if
Application.ScreenUpdating = True
End Sub
I have 2 spreadsheets:
main.xlsxm
drs.xlsx
I am trying to merge the two spreadsheets - this event will be launched after a button click on the main.xlsx spreadsheet (so the VBA code will reside on main.xlsx).
But I'm having difficulty writing my code, I originally tried using a variation of the following Excel formula but it was incredibly slow.
=IFERROR(INDEX([1.xlsx]Sheet1!$A:$A,SMALL(IF([1.xlsx]Sheet1!$B:$B=$A2,ROW([1.xlsx]Sheet1!$B:$B),99^99),COLUMN(A$1))),"")
I am trying to accomplish the following in VBA:
If column value E in drs.xlsx equals column value A in main.xlsx:
Then on the matching row in main.xlsx
Copy column value B in drs.xls to column value J in main.xlsx
If a second match is found (provided it is not the same as the first match):
Where column value E in drs.xlsx equals column value A in main.xlsx
Copy column value B in drs.xls to column value K in main.xlsx
If a third match is found (provided it is not the same as the first and second match):
Where column value E in drs.xlsx equals column value A in main.xlsx
Copy column value B in drs.xls to column value L in main.xlsx
If it happens for a fourth time then ignore…
How would I articulate this as VBA code?
This is my code so far (which prepares the spreadsheet ready):
Sub DRS_Update()
Dim wb As Workbook
Set wb = Workbooks.Open("C:\drs.xlsx")
With wb.Worksheets("Sheet1")
.AutoFilterMode = False
With .Range("A1:D1")
.AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
.AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
.AutoFilter Field:=4, Criteria1:="Workstation-Windows"
End With
End With
End Sub
Try following code. I've commented it in details, but if you have some questions, feel free to ask in comments:)
Sub test()
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim user As Range
Dim lastrowDRS As Long, lastrowMAIN As Long
Dim rng As Range, res As Range
Dim k As Byte
Dim fAddr As String
Application.ScreenUpdating = False
'specify sheet name for main workbook
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
'if drs is already opened
'Set wb = Workbooks("drs.xlsx")
'if drs not already opened
Set wb = Workbooks.Open("C:\drs.xlsx")
'specify sheet name for drs workbook
Set sh2 = wb.Worksheets("Sheet1")
With sh1
'find last row on column A in main wb
lastrowMAIN = .Cells(.Rows.Count, "A").End(xlUp).Row
'clear prev data in columns J:L
.Range("J1:L" & lastrowMAIN).ClearContents
End With
With sh2
.AutoFilterMode = False
'find last row on column A in drs wb
lastrowDRS = .Cells(.Rows.Count, "A").End(xlUp).Row
'apply filter
With .Range("A1:D1")
.AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
.AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
.AutoFilter Field:=4, Criteria1:="Workstation-Windows"
End With
On Error Resume Next
'get only visible rows in column E
Set rng = .Range("E1:E" & lastrowDRS).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'loop throught each user in main wb
For Each user In sh1.Range("A1:A" & lastrowMAIN)
'counter for finding entries
k = 0
'find first match
Set res = rng.Find(what:=user.Value, MatchCase:=False)
If Not res Is Nothing Then
'remember address of first match
fAddr = res.Address
Do
'user.Offset(, 9 + k) gives you column J for k=0, K for k=1, L for k=2
user.Offset(, 9 + k).Value = res.Offset(, -3).Value
'increment k
k = k + 1
'find next match
Set res = rng.FindNext(res)
'if nothing found exit stop searcing entries for current user
If res Is Nothing Then Exit Do
'if we already found 3 mathes, then stop search for current user
Loop While fAddr <> res.Address And k < 3
End If
Next user
End With
'close drs wb without saving changes
wb.Close saveChanges:=False
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
I am trying to write a macro that will let me copy a range of data from one sheet to another sheet based on a criteria in the column before the column to be copied.
Column B is the criteria column. If there is a 1 in any row in this column then columns C thru AN will be copied from that row where there is a 1 and be pasted into another sheet starting at the top of that sheet.
I have the following code. It locates the first row that satisfies the criteria and copies this row to the second sheet, however the code does not loop thru to find other rows that satisfy the criteria. How can I adjust the code to loop and copy each instance where the criteria is satisfied?
Sub testIt()
Dim i As Integer
Application.ScreenUpdating = False
Sheets("DataDump").Activate
For i = 2 To Range("B2").End(xlDown).Row()
If Range("B" & i).Value = 1 Then
Range("C" & i, "AN" & i).Copy
Sheets("PriceData").Activate
ActiveSheet.Range("B2", "AM2").Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub testIt()
Dim i As Long, shtSrc As Worksheet, rngDest As Range
Application.ScreenUpdating = False
Set shtSrc = Sheets("DataDump")
Set rngDest = Sheets("PriceData").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
For i = 2 To shtSrc.Range("B2").End(xlDown).Row
If shtSrc.Range("B" & i).Value = 1 Then
shtSrc.Range("C" & i & ":AN" & i).Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
End If
Next i
Application.ScreenUpdating = True
End Sub