I am trying to copy entire rows where two values are blank and the third cell value is MS-NORT,
My code is below but I am getting a syntax error.
please help
Set MK = Sheets("data dump").Range("P1:Q5000")
For Each cell In MK
If cell.Value = "" And Sheets("Data Dump").Range("M1:M5000") <> "MS-NORT"
Then cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
I'm not exactly sure what you mean by "where two values are blank and the third cell value is MS-NORT"
I've assumed you want to check each row and if column M <> "MS-NORT" and both columns P and Q are blank then copy the row. This code will do that
Sub test()
Dim rngRow As Range, MK As Range, lngrow As Long
Dim varCheckCol1 As Variant, varCheckCol2 As Variant, varCheckCol3 As Variant
Set MK = Sheets("data dump").Range("M1:Q5000")
For Each rngRow In MK.Rows
varCheckCol1 = rngRow.Value2(1, 1) 'col M
varCheckCol2 = rngRow.Value2(1, 4) 'col P
varCheckCol3 = rngRow.Value2(1, 5) 'col Q
If IsEmpty(varCheckCol2) And IsEmpty(varCheckCol3) And varCheckCol1 <> "MS-NORT" Then
rngRow.EntireRow.Copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next
End Sub
Related
I've been working on this for a bit, and I've just come to a roadblock. I'm trying to format some data for graphing in Excel, and it looks like this:
Example Data
I'd like to have the output look like this:
Desired Output
The actual number of faults and days vary wildly, so it has to be open-ended, so it can do a full search of the imported file. I'm trying to do it using VBA without relying on a formula.
Let me know if there's anything I could be doing different.
Here's the code:
Sub Graph()
Dim GraphDataWS, DataWS, FormWS As Worksheet
Dim criteria1, InspectedMtr As String
Dim totalrow, ErrorRangevar, DateRangeVar, Row1, Col1 As Long
Dim Daterange, ErrorRange As Range
Dim criteria2 As Variant
Dim ErrorCount, Output As Double
Worksheets("Graph Data").Activate
Set Worksheet = ActiveWorkbook.Sheets("Graph Data")
Cells.Select
Selection.ClearContents
Selection.ClearContents
Set GraphDataWS = ActiveWorkbook.Sheets("Graph Data")
Set FormWS = ActiveWorkbook.Sheets("Formulas")
Set DataWS = ActiveWorkbook.Sheets("Data")
totalrow = FormWS.Range("A21").Value
Worksheets("Data").Range("A1:A" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("B1"))
Worksheets("Data").Range("E1:E" & totalrow).SpecialCells(xlCellTypeVisible).Copy (Worksheets("Graph Data").Range("A1"))
With GraphDataWS
ErrorRangevar = GraphDataWS.Cells(Rows.Count, "A").End(xlUp).Row
GraphDataWS.Range("A1:A" & ErrorRangevar).Copy (GraphDataWS.Range("C1:C" & ErrorRangevar))
GraphDataWS.Range("C2:C" & ErrorRangevar).RemoveDuplicates Columns:=1
DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).Row
GraphDataWS.Range("B1:B" & DateRangeVar).Copy (GraphDataWS.Range("D1:D" & DateRangeVar))
GraphDataWS.Range("D2:D" & DateRangeVar).RemoveDuplicates Columns:=1
'DateRangeVar = GraphDataWS.Cells(Rows.Count, "B").End(xlUp).row
Range("D2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
ErrorRangevar = ErrorRangevar + 2
Worksheets("Graph Data").Activate
Output = 0
Set Daterange = GraphDataWS.Range(Cells(1, 4), Cells(1, DateRangeVar))
Set ErrorRange = GraphDataWS.Range("C1:C" & ErrorRangevar)
For a = 2 To ErrorRangevar
criteria1 = Cells(a, 3).Value
For b = 2 To ErrorRangevar
criteria2 = Cells(a, 4).Value
For i = 2 To ErrorRangevar
If ((Cells(i, 1)) = criteria1) And (Cells(i, 2) = criteria2) Then
Output = Output + 1
End If
Next i
Row1 = ErrorRange.Find(What:=criteria1).Row
Col1 = Daterange.Find(What:=criteria2).Column
Cells(Row1, Col1).Value = Output
MsgBox criteria1 & " " & Row1 & " " & criteria2 & " " & Col1 & " Output: " & Output
Output = 0
Next b
Next a
GraphDataWS.Range("E2").Value = Output
End With
End Sub
Any other suggestions or comments are welcome, I'm still learning VBA/Excel. Thank you!
First, I'm sorry as I can't understand this sentence :
to graph information from that
porting the information from a table
Anyway, other than create a pivot table from the data seen in your first image to get the expected result as seen in your second image ... I try to make the code based on the data seen in your first image to get the expected result as seen in you second image.
Sub test()
Dim rgdt As Range: Dim dateCol As Range: Dim cell As Range
Dim rgdt1 As String: Dim rgdt2 As String
Set rgdt = Sheets("Sheet1").UsedRange
Set rgdt = rgdt.Resize(rgdt.Rows.Count - 1, rgdt.Columns.Count).Offset(1, 0)
rgdt1 = "Sheet1!" & rgdt.Columns(1).Address
rgdt2 = "Sheet1!" & rgdt.Columns(2).Address
With Sheets("Sheet2").Range("A1")
.Value = "NAME"
rgdt.Copy Destination:=.Offset(1, 0)
.Range(rgdt.Columns(1).Address).RemoveDuplicates Columns:=1, Header:=xlNo
.Range(rgdt.Columns(2).Address).RemoveDuplicates Columns:=1, Header:=xlNo
Set dateCol = .Range(rgdt.Columns(2).Address).SpecialCells(xlConstants)
dateCol.Copy
.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
dateCol.Clear
For Each cell In .Range(rgdt.Columns(1).Address).SpecialCells(xlConstants)
With cell.Offset(0, 1).Resize(1, dateCol.Rows.Count)
.Value = "=countifs(" & rgdt1 & "," & cell.Address & "," & rgdt2 & ",B$1)"
.Value = .Value
.Replace What:=0, Replacement:="", MatchCase:=True
End With
Next
End With
End Sub
The sub assumed that there is nothing else in "Sheet1" but the data seen in your example data image.
First it create rgdt variable as the range of the data in "Sheet1" (sheet "Data" in your case, so change accordingly) without including the header.
Then it create rgdt1 and rgdt2 string variable to point which sheet and which column of rgdt.
Then it prepares the "skeleton" of expected result in "Sheet2" (Sheet "Graph Data" in your case):
fill cell A1 with "NAME"
copy the rgdt to cell A1.offset(1,0)
remove duplicate value in column A
remove duplicate value in column B
set the range of column B with data as dateCol variable (without the header)
copy the dateCol and paste transpose to cell A1.offset(0,1)
clear the value in dateCol
Next, it populate the value for the expected count result by looping to each cell which has value in column A, where on each loop it fill the range of cells after the looped cell to the right with COUNTIFS formula, remove the formula as value, then replace zero (0) result with nothing.
If you want to test the sub, create a new workbook, copy your data into cell A1 of "Sheet1", copy also the sub, then run the sub. See the expected result in "Sheet2".
So data gets pasted in to column B as the code keeps running it'll do a condition check to see there's any values in column B and paste a value in to the adjacent column A. I need to make it so it does two condition checks:
If there's values in column b, but then to check if there's values in column A before pasting so it doesn't overwrite different data that's been pasted already.
For Each Cell In y.Sheets("Compiled").Range("A:B")
If Range("B:B").Value <> "" And Range("A:A").Value = "" Then
Cell.Offset(0, -1).PasteSpecial xlPasteValues
End If
Next
You were close, don't try to loop over a multiple column range:
Sub Test()
For Each Cell In y.Sheets("Compiled").Range("B:B")
If Cell.Value <> "" And Cell.Offset(0, -1).Value = "" Then
Cell.Offset(0, -1).Value = Cell.Value
End If
Next
End Sub
NOTE: You are looping through every cell in Range("B:B") which is probably unnecessary. It'd be better if you use a lastrow value, or a static range like Range("B2:B1000"). Or you could use a criteria to exit your loop like If Cell.Value = "" Then Exit For.
Here's a version of the code that implements the lastrow value that dwirony mentioned in their answer. This also throws everything in arrays, so it might go a bit faster if you have a really large dataset.
Option Explicit
Sub test()
Dim ACol As Variant
Dim BCol As Variant
Dim lastrow As Long
Dim i As Long
lastrow = Range("B:B").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).row
BCol = Range("B1:B" & lastrow).Value
ACol = Range("A1:A" & lastrow).Value
For i = LBound(BCol) To UBound(BCol)
If IsEmpty(ACol(i, 1)) And Not IsEmpty(BCol(i, 1)) Then
ACol(i, 1) = BCol(i, 1)
End If
Next i
Range("A1:A" & lastrow).Value = ACol
End Sub
I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
I currently have a VBScript that takes in an Excel document and re-formats it into another Excel document that's more organized.
This code must also look at the values of the CATALOG column ("B1") and place it in the Drawings column ("M1") ONLY if the beginning of the value starts with "EDASM", "EDBSM" etc., yet the "ED" prefix must be eliminated when it's moved.
For example, Catalog number EDF12-01114 would result in nothing being placed in the drawings column, but with EDSM10265, we would need SM10265 to be placed in the drawings column (drop the "ED").
All I've got so far is this, which isn't even complete:
Set objRange = objWorkSheet.Range("M1").EntireColumn
IF
objWorkSheet.Range("B1").Row = "EDF*" THEN 'Maybe correct-ish? Not sure about syntax
objRange = Null
Else
objRange = ("B1") 'Totally an awful guess, but I have no clue what to put here
End If
I've seen similar code that has loops and whatnot, but none of them seem to be doing what I need to be done. Thank you!
EDIT: Current code based off of BruceWayne's. Still doesn't return anything in Excel datasheet's Drawing column, but it looks like it's closer...
Sub move_Text()
Dim lastRow, nextRow, cel , rng
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 3) <> "EDF" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next
End Sub
Another edit!
Catalog column is now "C", not "B". Also, I have two header rows, so the first catalog number is located in "C3".
Thanks again! We're getting closer.
Here's the Google Drive files: https://drive.google.com/folderview?id=0B2MeeQ3BKptFYnZfQWpwbTJxMm8&usp=sharing
IMPORTANT TO REMEMBER
In the Google Drive files: TestScript.vbs is the file where all the code is. When the script is run, select ExcelImport. That should return FinalDocument
I guess this is what you are looking for:
Sub move_Text()
Dim lastRow, nextRow, cel, rng
'get last row with data in Column B
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
'set your range starting from Cell B2
Set rng = Range("B2:B" & lastRow)
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If cel.Value Like "EDF*" Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf cel.Value Like "ED*" Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 11).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column Q
cel.Offset(0, 11).Value = cel.Value
End If
Next
End Sub
EDIT : For VBScirpt
________________________________________________________________________________
Sub Demo()
Dim lastRow, nextRow, cel, rng
Const xlShiftToRight = -4161
Const xlUp = -4162
Const xlValues = -4163
Const xlWhole = 1
Const xlPrevious = 2
With objWorksheet
'get last row with data in Column B
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
'set your range starting from Cell B2
Set rng = .Range("C2:C" & lastRow)
End With
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If InStr(1, cel.Value, "EDF", 1) = 1 Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf InStr(1, cel.Value, "ED", 1) = 1 Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 10).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column M
cel.Offset(0, 10).Value = cel.Value
End If
Next
End Sub
How's this work for you?
Sub move_Text()
Dim lastRow&, nextRow&
Dim cel As Range, rng As Range
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 2) = "ED" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next cel
End Sub
It will set the range to be your Column B, from row 1 to the last row. Then, loop through each cell in there, checking the left two letters. If "ED", then move the data, but take off the "ED".
Edit: Just realized you're using VBScript. Remove the as Range and & from the declarations, so it's just Dim lastRow, nextRow, cel, rng.
If your criteria is met, this will copy values (minus the ED prefix) from Column B to Column M.
Sub move_Text()
Dim lastRow , i
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To lastRow
If Left(Cells(i, 3), 2) = "ED" And Not (Left(Cells(i, 3), 3) = "EDF") Then
Cells(i, 13).Value = Right(Cells(i, 3, Len(Cells(i, 3)) - 2)
End If
Next
End Sub
Why not use some of excel's formulas to speed the whole thing up:
Sub My_Amazing_Solution ()
Range("M3").FormulaR1C1 = "=IF(TRIM(LEFT(RC[-10],2))=""ED"",RIGHT(TRIM(RC[-10]),LEN(RC[-10])-2),"""")"
Range("M3").AutoFill Destination:=Range("M3:M" & Range("C1048576").End(xlUp).Row), Type:=xlFillDefault
Application.Wait Now + TimeValue("00:00:03")
Range("M3:M" & Range("C1048576").End(xlUp).Row).Copy
Range("M3").PasteSpecial xlPasteValues
End sub
This should do it for you!
I am currently using this script.
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
For Each xCell In Selection
xCell.Value = CDec(xCell.Value)
Next xCell
I want to only select the cells in column E that have data, but the amount of cells that have data varies, and I don't want to select E1 because it has a header. This code changes the foreign text in column E to numbers that I can actually use the sum function to add up. The way it is written now it puts a 0 in all of the cells in the column infinitely.
Try following code:
Dim lastrow As Long
lastrow = Application.Max(2, Cells(Rows.Count, "E").End(xlUp).Row)
With Range("E2:E" & lastrow)
.NumberFormat = "0"
.Value = .Value
End With
UPD:
if it doesn't help, try this:
Dim lastrow As Long
lastrow = Application.Max(2, Cells(Rows.Count, "E").End(xlUp).Row)
For i = 2 To lastrow
With Range("E" & i)
.Value = CDec(.Value)
End With
Next