I have a sheet of data and in my data range column O has two values, new or previously pending which is based on another column with formulas. I m hoping to loop through each cell in column O and see which cells are new and paste it as values only. Right now I am getting next without for error.
Here is the part of my vba codes that failed.
'Values
With ActiveSheet.Range("O:O")
Dim x As Long
For x = 100 To 2 Step -1
If Cells(x, 15).Value = "New" Then
Cells(x, 15).Copy
Cells(x, 15).PasteSpecial xlPasteValues
Next x
End With
You don't have to start from the bottom to the top and you can count the rows so you don't loop to long.
Sub Button1_Click()
Dim Rng As Range, c As Range
Set Rng = Range("O2:O" & Cells(Rows.Count, "O").End(xlUp).Row)
For Each c In Rng.Cells
If c = "New" Then c.Value = c.Value
Next c
End Sub
Related
I have a macro right now that pulls data from a different sheet into a new sheet, then formats the data into a form I can use. The issue I have is that some of the PNs that I pull from the other sheet are in different cells for ease of viewing. (For example, the top level PN is in cell C2 and any parts that are a part of the part in C2 may be listed in D3, to show it's a sub-part).
I need code that will shift all PNs across varying columns into a single column. Once all PNs are moved, the other columns should be deleted (D through F). The data ranges from column C to F. Depending on the table the macro pulls data from, the length of the data varies. The macro will need to be able to handle this.
Here's an example of what my sheet looks like after my macro runs:
I'm trying to check column C for empty rows. If say C3 is empty, I then want to check D3 for text. If there is text, I want text in D3 to move to C3. If there is no text, check E3. Same process repeated. From what I've found online, I have this code so far (however, it doesn't run properly in my macro)...
'Copy PNs that are out of line and paste them in the correct column
Dim N As Long, i As Long, j As Long
Set ws1 = Worksheets("KDLSA")
N = ws1.Cells(Rows.Count, "C").End(xlUp).Row
j = 4
For Each cell In Range("D2:F" & ws1.Cells(Rows.Count, "F").End(xlUp).Row)
If cell.Value = "" Then 'if cell C is blank, I want to shift the text to fill column C
ws1.Range("C" & j).Value = ws1.Range("D" & cell.Row).Value 'copy PN in column E to column D - this needs to be more robust to cover my range of columns rather than just D and E
j = j + 1
End If
Next cell
Any help is appreciated.
Change your "For" block to:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, "F"))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range("D:F").EntireColumn.Delete
By cycling only through column C, you can loop through D-F only if C is blank, and when you find the one with data, it puts it in C.
If you also need dynamic range on the number of columns, then do:
With ws1.UsedRange
lastRow = .Rows(.Rows.Count).Row
lastColumn = .Columns(.Columns.Count).Column
End With
For Each cell In Range("C2:C" & lastRow)
If cell.Value = "" Then
thisRow = cell.Row
For Each horCell In Range(Cells(thisRow, "D"), Cells(thisRow, lastColumn))
If Not horCell.Value = "" Then
cell.Value = horCell.Value
Exit For
End If
Next horCell
End If
Next cell
Range(Cells(2, "D"), Cells(2, lastColumn)).EntireColumn.Delete
Or with a correct lastRow in your for loop "to" range, change your code to
If Not cell = "" then
ws1.range ("C" & cell.Row).Value = cell.Value
End if
You are looping through columns D-F, so "cell" is a cell in that range, not in column C. You therefore want to test for the ones that are NOT empty and then put their values in the corresponding cell in column C. :-)
As Tehscript mentioned you dont need a macro. If you nevertheless want to use a macro (maybe your real case is more complex than the example) here is a starting point for you.
The example below will shift the cells only once. So you might want to execute the loop several times. (You could also loop over the rowIndex and use a while loop for each row.)
The code could be further refactored but I hope this way it is easy to read.
Sub ShiftCells()
Dim myWorkSheet As Worksheet
Set myWorkSheet = Worksheets("Tabelle1")
Dim maxRowIndex As Long
maxRowIndex = GetMaxRowIndex(myWorkSheet)
Dim rowIndex As Long
Dim columnIndex As Long
Dim leftCell As Range
Dim rightCell As Range
For Each Cell In Range("C2:F" & maxRowIndex)
If Cell.Value = "" Then
shiftedCell = True
rowIndex = Cell.Row
columnIndex = Cell.Column
Set leftCell = myWorkSheet.Cells(rowIndex, columnIndex)
Set rightCell = myWorkSheet.Cells(rowIndex, columnIndex + 1)
leftCell.Value = rightCell.Value
rightCell.Value = ""
End If
Next Cell
End Sub
Function GetMaxRowIndex(ByVal myWorkSheet As Worksheet) As Long
Dim numberofRowsInColumnC As Long
numberofRowsInColumnC = myWorkSheet.Cells(Rows.Count, "C").End(xlUp).Row
Dim numberofRowsInColumnD As Long
numberofRowsInColumnD = myWorkSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim numberofRowsInColumnE As Long
numberofRowsInColumnE = myWorkSheet.Cells(Rows.Count, "E").End(xlUp).Row
Dim numberofRowsInColumnF As Long
numberofRowsInColumnF = myWorkSheet.Cells(Rows.Count, "F").End(xlUp).Row
Dim maxNumberOfRows As Long
maxNumberOfRows = WorksheetFunction.Max(numberofRowsInColumnC, _
numberofRowsInColumnD, _
numberofRowsInColumnE, _
numberofRowsInColumnF _
)
GetMaxRowIndex = maxNumberOfRows
End Function
I've been searching for more than 3 days to build this VBA Macro I need so any help would be much I appreciated.I want to build a macro with a Loop that will search for certain fixed text (this will be my reference step text) in a column let us say it's Column C, once it find that text will offset to the next cell to the left in Column B and this cell will have a variable text that I want to copy down to just before the next text step of C. I think Macro will be by making double loops, first loop to search for the text in column C and once find it will offset to adjacent cell of column B then another loop to copy & paste the value of cell of column B down to before the next text step of C and first loop will be performed on all column c. my trial with first loop was some how successful as I tried to make it either with identifying the certain text as a Boolean or using For Each loop. but my hard part was always in the second loop to increment the text of column B down to the cell before the next step of column C and relate the two loops to each other.
Below are my trials if you could help in them I would be much appreciated.
Sub test()
Dim i As Long
Dim ilastrow As Long
Dim n As string
ilastrow = Range("C1").End(xlDown).Row
Dim r As Range, cell As Range
Set r = Range("C1").End(xlDown).Row
For Each cell In r
If cell.Value = "TH" Then
ActiveCell.Offset(rowOffset:=0, columnOffset:=-1).Activate
n = ActiveCell.Value
'from here I want to copy n down to every cell until before next "TH" in column C then proceed with next "TH" as n will be changed and so on for all "TH" in Colmun C
End If
Next
End Sub
what I want to do with picture
any help will be much appreciated thanks in advance :)
This should do what you want:
Option Explicit
Sub test()
Dim sht As Worksheet
Set sht = ActiveSheet
With sht
Dim ilastrow As Long
ilastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Dim r As Range, cell As Range, prevCell As Range
Set r = .Range("C1:C" & ilastrow)
Set prevCell = Nothing
For Each cell In r
If cell.Value = "TH" Then
If Not prevCell Is Nothing Then
prevCell.Offset(1, -1).Resize(cell.Row - prevCell.Row - 1, 1).Value = prevCell.Offset(, -1).Value
Set prevCell = cell
Else
Set prevCell = cell
End If
End If
Next
ilastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
prevCell.Offset(1, -1).Resize(ilastrow - prevCell.Row, 1).Value = prevCell.Offset(, -1).Value
End With
End Sub
In the code below, my LastRow variable is not storing the right row number on the 27th loop (i = 27) causing the code to malfunction
I have used the F8 step through multiple times and noticed that the issue is on the 27th loop. The LastRow variable is meant to be +1204 rows from the previous LastRow value on each iteration of the loop, so I was expecting LastRow = 32509 instead of LastRow = 31316. For reference, on the 26th loop, LastRow = 31305. I'm not sure why the it is finding the wrong LastRow when the code has worked for the first 26 loops.
I am trying to get from my Source Table to my Desired Table:
Source Table
to
Desired Table
Also , the final error that shows is:
Run-Time error '1004': Application -defined or object- defined error
Sub Populate_entity()
Dim i As Integer
i = 1
Dim LastRow As Long
Dim SearchText As String
Do While i < 122 ' go across entity (columns wise)
If i = 1 Then
Range("E1").Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select 'snap to left (cell A1)
ActiveCell.Offset(0, 2).Select 'move to cell C1
ActiveCell.Offset(1, 0).Select ' move to cell C2
Else
ActiveCell.Offset(0, i + 1).Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Paste
ActiveCell.Offset(1203, 0).Select
ActiveSheet.Paste
ActiveCell.End(xlUp).Select
' ======== Error here ========
LastRow = Cells.Find(What:=SearchText, After:=ActiveCell, LookIn:=xlValues, SearchOrder:=xlByRows).Row
Range("C" & ActiveCell.Row & ":C" & LastRow).FillDown
ActiveCell.End(xlUp).Select
i = i + 1
Loop
End Sub
A summary of what you want, as you described in the comments:
Copy the values from cells E1:DU1, paste each cell 1204 times in column C.
1st loop it will paste cell E1 in C2:C1205
2nd loop it will paste cell F1 to C1206:C2409
etc.
This code achieves that:
Sub Populate_entity()
' Declare 2 range variables (top row to copy from and paste destination)
Dim RowRange As Range
Dim PasteCells As Range
' Use the With block to specify the sheet. If you want the destination
' to be another sheet, then you can specify that instead:
' ThisWorkbook.Sheets("SheetName").Range("...")
With ThisWorkbook.ActiveSheet
Set RowRange = .Range("E1:DU1") ' Set range to copy from
Set PasteCells = .Range("C2:C1205") ' Set paste cells, blocks of 1204 cells in column C
End With
' Loop through RowRange, copy each cell's value into PasteCells
' Then offset the PasteCells range by 1024 rows, so next RowRange cell
' is inserted underneath previously copied cells.
Dim ofst As Long
For ofst = 1 To RowRange.Cells.Count
' Use .Value to avoid the (comparably slow) copy/paste operation
PasteCells.Offset((ofst - 1) * 1204, 0).Value = RowRange.Cells(ofst).Value
Next ofst
End Sub
In my opinion you don't need any search because your code always places the SearchString in row 1205. Since you know that it is there you don't need to look for it. This thought brings me to the code below.
Sub Populate_Entity()
Dim C As Long ' Column
Dim Target As Range
Dim FirstRow As Long
Dim LastRow As Long
FirstRow = 2
LastRow = 7 '1205
C = 3
Range("C2").value = Range("E1").value
' Cells(2, C).Value = Cells(1, 5).Value
Do
Set Target = Range(Cells(FirstRow, C), Cells(LastRow, C))
Target.FillDown
C = C + 1
Cells(2, C).value = "Can't figure"
Loop While C < 3 ' 122
End Sub
I have cut the loop short to only 7 rows (instead of 1205) and 3 columns (instead of 122). I just couldn't figure out where the text in the FirstRow should come from. For column C it comes from E1, but where does it come from in the subsequent columns? You can fill this in using the method I showed you above, like, Cells(2, C).Value = Cells(1, 5).Value. I believe that the 5 can be replaced by a value derived from the current C, perhaps C + 2.
Note the Cells(2, C).Value doesn't refer to the value in cell C2. Instead if refers to the cell in Row 2, Column C.
I'm new in VBA coding, and would really appreciate some help solving this problem.
I need to do as follows:
Compare every value in column G, Worksheet1, to the Unique values in column D, Worksheet2.
If a value matches, copy from that row values in column: C, G & I
Paste every match into Worksheet3
I've tried this so far:
Sub test()
Application.ScreenUpdating = False
Dim rng1 As Range, rng2 As Range, rngName As Range, i As Integer, j As Integer
For i = 1 To Sheets("Worksheet1").Range("G" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Worksheet1").Range("G" & i)
For j = 1 To Sheets("Worksheet2").Range("D" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Worksheet2").Range("D" & j)
Set rngName = Sheets("Worksheet1").Range("H" & j)
If rng1.Value = rng2.Value Then
rngName.Copy Destination:=Worksheets("Worksheet3").Range("B" & i)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
But it doesn't work.
There is a problem with this statement:
Set rngName = Sheets("Worksheet1").Range("H" & j)
The variable j refers to a row in Worksheet2, but you use it on Worksheet1. Depending on what you intended here, you should either change the worksheet name or use the variable i instead of j.
Assuming it is the first, the code could also be written as:
Dim rng1 As Range, rng2 As Range
' Iterate over the used cells in the G column of Worksheet1
For Each rng1 In Sheets(1).UsedRange.Columns(8 - Sheets(1).UsedRange.Column).Cells
' Iterate over the used cells in the D column of Worksheet2
For Each rng2 In Sheets(2).UsedRange.Columns(5 - Sheets(2).UsedRange.Column).Cells
If rng1.Value = rng2.Value Then
' Copy value from the C column in Worksheet2 to the B column in Worksheet3
Sheets(3).Cells(rng2.Row, 2).Value = rng2.Offset(0, -1).Value
End If
Next
Next
Alternative to VBA code
Instead of using code, you could do this with formulas.
For instance in Worksheet3 you could put this formula in B1:
=INDEX(Worksheet2!$C:$C, MATCH(Worksheet1!$G1,Worksheet2!$D:$D, 0))
Here is an explanation of the two main parts of that formula:
MATCH(Worksheet1!$G1, Worksheet2!$D:$D, 0)
This part will take the value from Worksheet1!$G1, find it in Worksheet2!$D:$D (i.e. the complete D column) and return the row number where it was found. The last argument (0) makes sure that only exact matches count.
INDEX(Worksheet2!$C:$C, ...)
The row number returned by MATCH will be used to get a value from the C column of Worksheet2, at that same row.
You can change that $C:$C by $H:$H to get the value from the H column, etc.
Drag/copy the formula downwards to repeat it for other rows.
I would use the Cells property and a Do loop to loop through G on WS1. Try something like this:
Dim i as Integer, j as Integer
Dim c as Range
i = 2 'Will be used to loop through WS1, Column G
j = 1 'Will be used to find next empty row in WS3
Do Until Sheets(1).Cells(i, 7).Value = ""
Set c = Sheets(2).Range("D2")
Do Until c.value = Sheets(1).Cells(i, 7).Value Or c.value = ""
Set c = c.Offset(1, 0)
Loop
If c.value = Sheets(1).Cells(i, 7).Value Then
'Find first empty row in WS3
j = 1
Do Until Sheets(3).Cells(j, 1).Value = ""
j = j + 1
Loop
'Copy row
Sheets(3).Rows(j).value = Sheets(1).Rows(I).value
End if
i = i + 1
Loop
Set c = Nothing
I'm working on cleaning up timesheets for an Access database, and I'm having issues with cleaning up the data.
I have a time sheet with names in the first column, then all of the columns after that, from C to M (or so) have hours. What I am trying to accomplish is that when the Macro finds a name in the first column, it selects the columns in that row, finds the cells without hours, and fills them with zeroes
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
Next
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next
I'm attempting to loop and fill rows with zeroes based on the cell having a named entered in it. The problem that I'm running into is that cells are only being filled in the last name/row in the spreadsheet. The macro seems to be skipping over all but the last row.
I'm just learning VBA, so maybe I'm just missing something in the syntax.
Thanks for the help!
The problem is that you are moving on to the next selection, all the way to the last row, before you start filling in your 0s. Try this modification to your code:
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
Using this method, you fill in the 0s before moving on to the next selection/row.
Note: I avoid the use of .select/Selection because of the problems it can cause, so I am not sure if you will receive an error message if a row does not contain a name. If you wish to avoid this potential error, try the below:
Dim r As Integer
Dim c As Range
Dim c2 As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Set c2 = Range(Cells(r, 3), Cells(r, 10))
End If
For Each c In c2
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
By the way, did you strip out the Workbook and Sheet names from Range(Cells(r, 3), Cells(r, 10)) to simplify your post? I was surprised you were able to use that without errors. If so, you'd obviously have to put them back in for my code to work.
possibly,
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeConstants)
Rng = 0
End Sub
You want to take all of the blank cells and turn them into zeroes.
Sub zeroed_hours()
Dim rw As Long
With Sheets("Sheet1") '<-set this worksheet reference properly!
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If CBool(Len(.Cells(rw, 1))) Then 'found a name!
'C:M on this row
.Cells(rw, 3).Resize(1, 11).Replace what:="", replacement:=0, lookat:=xlWhole
End If
Next rw
End With
End Sub
This loops through the cells in column A. If it finds a value (something with length greater than zero) then it replaces all blank cells in C:M on that row with zeroes.