I'm trying to create a vba code but I'm not succeeding.
I want to search on COLUMN "F", for value: "Answered"
then copy row from "COLUM B TO F" and paste on sheet "ControlAnswered" lastrow;
Try this,
Sub SpecialCopy()
Dim targetSh As Worksheet
Set targetSh = ThisWorkbook.Worksheets("ControlAnswered")
Dim i As Long
For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
If Cells(i, 6).Value = "Answered" Then
Range(Cells(i, 2), Cells(i, 6)).Copy Destination:=targetSh.Range("A" & targetSh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
End Sub
I should say that you will not always going to find people that will write code for you
Related
I am trying to find value that contain decimal point in the column F, then copy those row into another sheet.
I don't know how to find the value of decimal. If I set the Value = "1", it will work, it will copy the row that have number 1 in it to another sheet. Need some help
Sub SpecialCopy()
Dim targetSh As Worksheet
Set targetSh = ThisWorkbook.Worksheets("Error")
Dim i As Long
For i = 1 To Cells(Rows.Count, "F").End(xlUp).Row
If Cells(i, 6).Value = "." Then
Range(Cells(i, 2), Cells(i, 6)).Copy
Destination:=targetSh.Range("A" & targetSh.Cells _
(Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
End Sub
I am attempting to copy column B from sheet called "Activity Overview" (Only filled cells) and paste in a sheet called "V&VFile" in column E from row 11 onwards, however when i run the macro the cells arent copied and seems to paste blank cells.
The source of the data uses excel formula index match, is this why as it can copy the data as its found from an excel formula?
Sub VVfileFILL()
Dim Lastrow As Double
Lastrow = Worksheets("Activity Overview").Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("Activity Overview").Range("B" & Lastrow).Copy
ThisWorkbook.Sheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).PasteSpecial xlPasteValues
End Sub
Don't think one can avoid a loop in this situation.
Sub VVfileFILL()
Dim Lastrow As Long, r As Long, n As Long
n = Worksheets("V&V").Range("E" & Rows.Count).End(xlUp).Offset(10, 0).Row
With Worksheets("Activity Overview")
Lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
For r = 2 To Lastrow
If Len(.Cells(r, "B")) > 0 Then 'check not blank
If WorksheetFunction.CountIf(Worksheets("V&V").Range("E1:E" & n), .Cells(r, "B")) = 0 Then 'check not already in E
Worksheets("V&V").Cells(n, "E").Value = .Cells(r, "B").Value 'transfer value
n = n + 1 'add 1 to destination row
End If
End If
Next r
End With
End Sub
I am trying to copy certain column from one worksheet to another but when I apply my code, I get no errors but also no results. I get blank paper. I applied this methodolgy on copying a certain row and it was copied to another worksheet perfectly.
This is regarding the successful attempt to copy row.
The code works just fine:
Sub skdks()
Dim OSheet As Variant
Dim NSheet As Variant
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Tabelle3" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).row
End If
'If cell has "certain # then..."
If Cells(i, 1).Value = Cells(13, 2).Value Then
Cells(i, 1).EntireRow.Copy
Sheets(NSheet).Cells(NSLRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
This little piece of code is the failed attempt to copy column to another worksheet.
Sub trial()
Dim OSheet As Variant
Dim NSheet As Variant
Dim j As Integer
Dim LColumn As Integer
Dim NSLColumn As Integer
OSheet = "Tabelle2" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LColumn = Sheets(OSheet).Cells(1, Columns.Count).End(xlToLeft).Column 'Last Column in Old Sheet
Sheets(OSheet).Activate
For j = 2 To LColumn
'Finds last column in the New Sheet
If Sheets(NSheet).Cells(1, 2) = "" Then
NSLColumn = 1
Else
NSLColumn = Sheets(NSheet).Cells(1, Columns.Count).End(xlToLeft).Column
End If
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next j
End Sub
....
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
debug.Print Cells(2, j).Address; " = "; Cells(13, 2).Address; " ---- COPY"
debug.print Cells(2, j).EntireColumn.address; Cells(2, j).EntireColumn.cells.count
debug.Print Sheets(NSheet).Cells(2, 2).Address
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
....
With the line If Cells(2, j) = Cells(13, 2) Then you compare the different cells from row 2 (B2, C2, D2, ...) with the value of cell "B13". If the value is the same you copy this column to the new worksheet.
Is there any equal value in your data? If yes you should get an error message with your code.
You try to copy the values of an entire column to the range starting with "B2". Of cause there is not enough space for this.
=> Either you reduce the source range or you start the destination range on row 1!
To add to the paste destination size, if you really want to paste the entire column, you either need to start at the beginning of the column or choose the entire column. Also, I think you want to make the paste column increase with your NSLColumn
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Columns(NSLColumn + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Ideally, what i need is to email the sepcified range rows with "x" in their column, i tried a code and it's working grand but the only problem is that it's sending 3 emails for 3 rows, but i want to send all the records in one email. I was able to do that using a vba code that converts the selected range in HTML and email it out. Now i want to automate the selection part.So basically i need to select the specified range of any row which have "x" in first column.
I tried a code but it's only selecting the last row that contains "x".
Link for the image showing what i am exactly looking for - https://imgur.com/a/Zq97ukL
Sub Button3_Click()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim Sheets As Worksheet
Dim r1 As Range
lRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lRow
If (Cells(i, 1)) = "x" Then 'change this range
Set r1 = Range(Cells(i, 2), Cells(i, 4))
r1.Select
On Error Resume Next
On Error GoTo 0
Cells(i, 10) = "Selected " & Date + Time 'column J
End If
Next i
ActiveWorkbook.Save
End Sub
jsheeran posted the bulk of this, but deleted his answer because it wasn't finished.
As previously stated, there is probably no reason to select anything.
Sub Button3_Click()
Dim lRow As Long
Dim i As Long
Dim toDate As Date
Dim Sheets As Worksheet
Dim r1 As Range
lRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1).Value = "x" Then
Set r1 = Union(IIf(r1 Is Nothing, Cells(i, 2).Resize(, 3), r1), Cells(i, 2).Resize(, 3))
Cells(i, 10).Value = "Selected " & Date + Time
End If
Next i
If Not r1 Is Nothing Then r1.Select
ActiveWorkbook.Save
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!