I have a script that loops through a list of ID numbers to check if there is a matching ID in another list, if there is a matching ID, it copies the email in the adjacent column and pastes it in another range. I am having trouble copying an offset range since it doesn't appear to be pasting any values. This script is not throwing any errors:
Sub tryThis()
Dim lookHere As Range, pasteHere As Range, cell As Range, searchList As Range
Set List1 = Range(Range("A1"), Range("A1").End(xlDown))
Set List2 = Range(Range("C1"), Range("C1").End(xlDown))
For Each cell In List1
Set found = List2.Find(what:=cell, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not found Is Nothing Then
cell.Offset(, 1).Resize(, 1).Copy Destination:=Cells(Rows.Count, "G").End(xlUp)
End If
Next cell
End Sub
This:
cell.Offset(, 1).Resize(, 1).Copy _
Destination:=Cells(Rows.Count, "G").End(xlUp)
will copy the value into the same cell each run, since End(xlUp) takes you to the last occupied cell in the column, not the first empty cell. You need to Offset() one down to the next empty position. Also can do this with a direct value assignment:
Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Value = cell.Offset(0, 1).Value
Edit: if the cell you want to copy is from List 2 then:
Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Value = found.Offset(0, 1).Value
Related
My aim is to have a formula that fills the empty cells with the previous Q. question, until the last non empty cell (see picture)
The range is the last non empty cell of my row.
For now my code looks like this :
Sub Range_End_Exemple()
Dim cell_target As Range
ActiveCell.FormulaR1C1 = "=+IF(ISBLANK(R[-2]C)=TRUE,RC[-1],R[-2]C)"
Set cell_target = Worksheets("dataset Feedback forms").Range(Cells(1, Columns.Count).End(xlToLeft).Select Type:xlFillDefault
End Sub
Thanks for you help if you have any suggestion.
The sub below is only based the picture you attached.
Sub test()
Dim LastCol As Range
Dim rg As Range
Dim cell As Range
With ActiveSheet
Set LastCol = .Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 0)
Set rg = .Range("D1", LastCol)
For Each cell In rg.SpecialCells(xlCellTypeConstants)
If cell.End(xlToRight).Column = .Columns.Count Then
Range(cell, LastCol).Value = cell.Value
Else
Range(cell, cell.End(xlToRight).Offset(0, -1)).Value = cell.Value
End If
Next
End With
End Sub
The code assumed that nothing is change in "header-2".
The "header-1" will start in cell D1.
How many "type of header-1" is unknown.
The last column used in "header-2" is unknown.
The process:
it get the cell of the last column used in "header-2" then offset the row to -1 then have it as the LastCol variable. The LastCol cell is used to mark the end of "header-1".
then it get the range of the "header-1" into rg variable.
then it loop the cells of the rg which has value,
copy the cell till the last empty cells to the right (before the next header type of "header-1").
since the last header type of "header-1" will have no border, then it will check if the last empty cell column to the right value = the worksheet columns count ... then it use the LastCol variable as the border.
Based on seeing your image attachment, the thing which I'm unable to understand on what you want is : you use a formula for your "header-1" ?
so I'd imagine something like this:
lrow = Cells.Find("*", Cells(1, 1), xlValues, xlPart, xlByColumns, xlPrevious, False).Column ' <-- this gives you the last column blank
nextblank = Cells.Find("", Cells(1, 1), xlFormulas, xlByColumns, xlNext, False).Column ' <-- this gives you the FIRST blank column number
ltr = Split(Cells(1, nextblank - 1).Address, "$")(1) ' <-- this gives you the letter
aux = Range(ltr & "1") ' <-- this is the value you need to copy
After the first nextblank statement you need to use this to iterate
nextblank = Cells.Find("", Cells(1, nextblank), xlFormulas, xlByColumns, xlNext, False).Column
Using those values -> lrow doesn't change, it's your final destination
nextblank,ltr and aux values changes after you copy
Hope it helps!
This will do what you appear to want from your image:
Sub Propagate()
Dim lastCol As Integer
With Worksheets("dataset Feedback forms")
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
With .Cells(1, 4).Resize(1, lastCol - (4 - 1)).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=RC[-1]"
.Value2 = .Value2
End With
End With
End Sub
I have a report that contains values in two columns (B:C), when column B has a value, column C has an empty cell for the same row.
What I want to achieve is to create a macro to search for a specific value (i.e "Desktop") in the column A and if it matches the search, copy/cut the value and paste it one cell to the next column but in the same row (that is meant to be blank), so all the values are aligned in one column (i.e "Desktop" found in A1, then paste it to B1 without creating a new column).
Example:
3 ways to get the job done.
Dim cel As Range
'This will search for "Desktop" and copy it to the cell on the right.
For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Value = "Desktop" Then
cel.Offset(, 1).Value = cel.Value
'The line below will remove "Desktop" from the cell if required
'cel.ClearContents
End If
Next cel
'Or
'This will search for "Desktop", insert a cell and shift to the right.
For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Value = "Desktop" Then
cel.Insert Shift:=xlToRight
End If
Next cel
'Or
'This will search for any empty cell in Col C and copy the value from Col B.
For Each cel In Range("C2", Cells(Rows.Count, 3).End(xlUp))
If cel.Value = "" Then cel.Value = cel.Offset(, -1).Value
'The line below will remove "Desktop" from the cell if required
'cel.Offset(, -1).ClearContents
Next cel
So, I'm looking for a way to skip specific columns in a row copy. I'm working with doing a bunch of loops to copy/paste from a bunch of sheets of variable sized reports and I want a way to simply skip a column or columns in a row copy since I can't just do a entirecolumn.delete to deal with the excess and doing a counter system might get broken. I guess what I'd like (which doesn't exist as far as I know) is something like a row copy columns 3 to 5 ignore.
Dim LastRow As Long
Dim LastCell As Range
For Each Cell In Sheet10.Range("A:B")
If Cell.Value Like "*Total*" Then
Set Mastersheet = Sheet10
Set Pastesheet = Sheet3
Cell.EntireRow.Copy
With Pastesheet
Set LastCell = Pastesheet.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
End If
Pastesheet.Cells(LastRow + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Next
Here is how i would accomplish your task, broken-down into steps.
Dim rw As Range
'Step 1: Insert helper column
Columns(3).Insert
'Step 2: If any cell in columns A or B contain the word "Total", put "1" in the helper column
For Each rw In Worksheets("Sheet10").UsedRange.Rows
If rw.Cells(1, 1).Value Like "*Total*" Or rw.Cells(1, 2).Value Like "*Total*" Then
rw.Cells(1, 3).Value = "1"
End If
Next
'Step 3: Filter using the helper column, hide the helper column and 3 other columns, copy(offset removes header row), paste to sheet3 lastrow +1
With Range("A1").CurrentRegion
.AutoFilter Field:=3, Criteria1:="1"
.Columns("C:F").Hidden = True
.Offset(1).SpecialCells(xlVisible).Copy Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
'Step 4: Clean up Sheet10, or macro will not work next time
With Sheet10
.AutoFilterMode = False
.Columns.Hidden = False
.Rows.Hidden = False
.Columns(3).Delete
End With
I have a vba code that copies a file multiple times and renames the output after a list of names in column D from sheet "Linkuire".
Column D is full of concatenate formulas that bring data into cells till D1000.
When the concatenate formulas return "" (as in nothing) i want the code to ignore that cell.
' the range of cells that contain the rename list
With ActiveWorkbook.Sheets("Linkuire")
Set rRenameList = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
Now it just takes into account all D2 to D1000 cells even if some are = ""
How can I make the code ignore all cells where the return of the concatenate is "" ? (I have the same problem with a vba code that converts a certain sheet into pdf - with data got from concatenate formulas. It converts all cells even if concatenate return "" and is blank)
Thank you..
edited since pure SpecialCells() approach wouldn't work
You could use following two approaches and avoid looping:
AutoFilter() and SpecialCells() approach:
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D1", .Cells(.Rows.count, "D").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>" '<--| filter out blanks
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set rRenameList = .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
End With
Formula and SpecialCells() approach
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D2", .Cells(.Rows.count, "D").End(xlUp))
.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]="""", 1,"""")"
Set rRenameList = .Offset(, 1).SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1)
.Offset(, 1).ClearContents
End With
End With
in this approach you're writing a formula in a "helper" column I chose to be the adjacent to the right. It can be adjusted to any other offset
This should work. It will loop through your range, and only add the cell address to your rRenameList when the length is greater than or equal to 1.
Sub Test()
' Adapted from http://stackoverflow.com/a/8320884/4650297
Dim rng1 As Range, rRenameList As Range, cel As Range
With ActiveWorkbook.Sheets("Linkuire")
Set rng1 = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
For Each cel In rng1
If Len(cel) >= 1 Then
If Not rRenameList Is Nothing Then
Set rRenameList = Union(rRenameList, cel)
Else
' the first valid cell becomes rng2
Set rRenameList = cel
End If
End If
Next cel
Debug.Print rRenameList.Address
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!