sI'm making a spreadsheet to update Project data for my company. I have code to identify what rows the new data should be inserted on, but am having trouble writing the command to properly paste the new data on the index. My code is:
Set wsDest = Worksheets("Projected Hours")
Dim uniqueid As String
Dim rng As Range, c As Range, myRng As Range
'Set range with values to be searched for matches
Set rng = wsDest.Range("projid")
'Fill string variable with string of text to be matched
uniqueid = Range("projectid")
'Loop through each cell in range
For Each c In rng
'Check if cell value matches the string to be matched
If c.Value = uniqueid Then
'Check if this is the first match (new range hasn't been filled yet)
If myRng Is Nothing Then
'Fill new range with cell
Set myRng = c
Else
'Join new matching cell together with previously found matches
Set myRng = Application.Union(myRng, c)
End If
End If
Next c
'Select entire row of each cell in new range
destrows = myRng.Rows
For Each Row In destrows
Range("newprincipal").Copy
wsDest.Range("D" & destrows()).PasteSpecial Paste:=xlPasteValues
Range("newinfo").Copy
wsDest.Range("F" & destrows()).PasteSpecial Paste:=xlPasteValues
Next Row
End Sub
Which gives the error "Subscript out of Range" on the first paste line. Am I indexing wrong? What should I change to paste the new information in these specific columns (D and F) in each row of the index? I need the last part to take each value in destrows, which should be a row number and paste my selections into D+(Row Number) and F+(Row Number).
I figured it out. Instead of defining my target rows first, I edited my code to paste in my info as it found the correct rows.
Sub UpdateProject()
Set wsDest = Worksheets("Projected Hours")
Dim uniqueid As String
Dim rng As Range, c As Range
'Set range with values to be searched for matches
Set rng = wsDest.Range("projid")
'Fill string variable with string of text to be matched
uniqueid = Range("projectid")
For Each c In rng
If c.Value = uniqueid Then
Range("newprincipal").Copy
wsDest.Range("D" & c.Row).PasteSpecial Paste:=xlPasteValues
Range("newinfo").Copy
wsDest.Range("F" & c.Row).PasteSpecial Paste:=xlPasteValues
End If
Next c
End Sub
Related
I need to select a range of data in column Q that meet criteria found in column A (specifically, I wish to select only those cells which correspond to non-"" values in column A). The resulting range of selected cells will be non-contiguous.
I then want to copy these cells and paste their values in column K. The pasted values should retain the same row references as the copied range; basically, I'm just taking the values in the copied range and pasting the values x many columns to the left.
The problem I'm encountering is that it seems to only copy the final value in column Q and then paste this value in column K. So, I seem to be getting it to paste in the right place, but it's not copying the way I want it to.
The code I've written can be found below.
Option Explicit
Sub NonConRngPaste()
Dim rCell As Range
Dim rRng As Range
Dim r As Range
Dim pasteRng As Range
For Each rCell In Range("A1:A1000")
If rCell.Value <> "" Then
If rRng Is Nothing Then
Set rRng = rCell
Else
Set rRng = Application.Union(rRng, rCell)
End If
End If
Next
Set pasteRng = rRng.Offset(0, 10)
For Each r In rRng.Offset(0, 16).Cells
pasteRng.Value = r.Value
Next
End Sub
May as well be simpler?
Sub NonConRngPaste()
Dim c As Range
Application.Screenupdating = False
For Each c In Range("A1:A1000").cells
If len(c.value) > 0 Then
with c.EntireRow
.Columns("K").Value = .Columns("Q").Value
end with
End If
Next
End Sub
I am trying to write a macro that tidies up and interrogates raw data exported from some analytical instrumentation. I would like it to look through one column (sample names) down all rows and look for indicators of specific sample types e.g. duplicates. Finding these indicators I want to insert a row, and in the new inserted row do some simple calculations based on the two rows above. For now I will just be happy getting the row insertion to work.
I can get it to find the key word and insert 1 row, but it finds the first one and stops. There are multiple instances of these keywords in my data, and i want to insert a row below each
'original code - finds first keyword, inserts row and stops
Sub dup_finder()
Dim colHeader As Range
Set colHeader = Range("B1:B500")
Dim currCell As Range
Set currCell = Cells.Find("*_dup")
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
'my attempt to include loop - inserts 500 rows below keyword! stops
after first instance
Sub dup_finder()
Dim colHeader As Range
Dim row As Long
Dim currCell As Range
Set colHeader = Range("B1:B500")
Set currCell = Cells.Find("_dup")
For row = 1 To 500
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Next row
End Sub
I suggest always fully qualifying your ranges with the workbook and sheet.
You should be able to adapt this to what you want. You simply enter the range you want to check in, and the value you are checking for.
It works backwards, up through the range, inserting a row below each one it finds.
Sub InsertRows()
''Declare your variables
Dim RngToCheck As Range, ValToFind As String
''Set the range in which to look for your desired string.
Set RngToCheck = ThisWorkbook.Sheets("Sheet1").Range("B1:B500")
''Set what string to look for.
ValToFind = "_dup"
''Declare a variable to use as a counter
Dim i As Long
''Count backwards through each of the rows in the range.
''(If you went forwards through the range, the rows you
''are inserting would become part of that range and push
''the bottom rows (which you intended to check) out of the range).
For i = RngToCheck.Rows.Count To 1 Step -1
''Check if the last characters (the number of characters to
''check is defined by the length of the string we are looking
''for) of the current cell match the string we are looking for.
If Right(RngToCheck(i).Value, Len(ValToFind)) = ValToFind Then
''Insert the row (we need to offset by 1 row
''because rows are inserted ABOVE, and we
''want it BELOW the current cell).
RngToCheck(i).Offset(1, 0).EntireRow.Insert
''Now you can add your formulas to the new row...
''column A
RngToCheck(i).Offset(1, -1).Formula = "=1+1"
''column B
RngToCheck(i).Offset(1, 0).Formula = "=2+2"
''column C
RngToCheck(i).Offset(1, 1).Formula = "=A" & RngToCheck(i).Offset(1, 1).Row & "+B" & RngToCheck(i).Offset(1, 1).Row
''column D
RngToCheck(i).Offset(1, 2).Formula = "Hello"
''And so on...
End If
Next i
End Sub
Assuming you do want to insert a row under every instance of a cell in column B containing "_dup" this should work.
The problem with your code was that it wasn't looping and so only ever found one instance.
It's advisable not to specify a fixed range as you are inserting rows and the range will expand; however, you could do this and set the search direction as "previous".
Sub dup_finder()
Dim colHeader As Range, s As String
Set colHeader = Range("B1:B500") ' not actually used
Dim currCell As Range
'are we searching just B or the whole sheet?
Set currCell = Columns(2).Find(What:="_dup", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False) 'change parameters to suit
If Not currCell Is Nothing Then
s = currCell.Address 'store address of first found cell
Do
currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Set currCell = Columns(2).FindNext(currCell) 'find next case
Loop Until currCell.Address = s 'keep looping until we are back to the original case
End If
End Sub
So i want to make a loop where it checks the data in every cell in a column and if the cell has any type of data, it copy's the entire row to a different ss. If the cell is blank i need it to move onto the next cell below and not copy the row.
I have added some code below, im trying to copy all the rows in report1 in column H:H that have any input to Report3.
Sub GenerateReport3_Click()
Dim rep1 As Worksheet
Dim rep3 As Worksheet
Set rep1 = ThisWorkbook.Worksheets("Report1")
Set rep3 = ThisWorkbook.Worksheets("Report3")
Dim rngA As Range
Dim cell As Range
rep1.Range("A1:J1").Copy Destination:=rep3.Range("A1")
Set rngA = Sheets("Report1").Range("H:H")
For Each cell In rngA
If cell.Value = True Then
cell.EntireRow.Copy Destination:=rep2.Range("A" & Rows.Count).End(xlUp)(2)
End If
Next cell
End Sub
Every row in column in report 1 H:H that has any input needs to be copied to Report3.
Test for Not IsEmpty(...) rather than =TRUE.
Also, a few details around geting Range references need work (eg avoiding implicit references to ActiveSheet).
And don't loop over the entire 1,000,000+ rows in a column (That's so slow!)
Something like this
Sub GenerateReport3_Click()
Dim rep1 As Worksheet
Dim rep3 As Worksheet
Set rep1 = ThisWorkbook.Worksheets("Report1")
Set rep3 = ThisWorkbook.Worksheets("Report3")
Dim rngA As Range
Dim cell As Range
rep1.Range("A1:J1").Copy Destination:=rep3.Cells(1, 1)
With rep1
Set rngA = .Range(.Cells(1, "H"), .Cells(.Rows.Count, "H").End(xlUp))
For Each cell In rngA
If Not IsEmpty(cell) Then
cell.EntireRow.Copy Destination:=rep3.Cells(rep3.Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next cell
End With
End Sub
Note that if this is still too slow, there a are more ways to speed it up
Here's what I have:
Response Flow
I have one sheet called Response Flow that has Response, Y/N and a Total. If the Response has a Y next to it I want to match the Response Name with the Response Name on Sheet 2 ("Campaigns") and insert a formula in the column next to the response name on Sheet 2 using VBA code. Below is what I have so far.
Sub Volume_Calc()
Dim LastRowR As Long
Dim LastRowC As Long
Dim LastRowI As Long
Dim LastRowA As Long
Dim rngFoundCell As Range
Dim cell As Range
Dim text As String
Dim FindRow As Range
LastRowR = Range("C65536").End(xlUp).Row
LastRowC = Range("K65536").End(xlUp).Row
LastRowI = Range("I65536").End(xlUp).Row
LastRowA = Range("A65536").End(xlUp).Row
Set FindRow = Worksheets("ResponseFlow").Range("C:C").Find(What:="Y",
LookIn:=xlValues)
Do While FindRow = True
If Application.Match(Worksheets("Campaigns").Range("K6"),
Worksheets("ResponseFlow").Range("A4:A" & LastRowA), 0) Then
Worksheets("Campaigns").Range("I6:I" & LastRowI).Formula = "=INDEX(ResponseFlow!$B$3:$B$145,MATCH(Campaigns!$K6,ResponseFlow!$A$3:$A$145,0))"
End If
Loop
End Sub
What you're intending to do seems like it'd be easier to do in Excel without VBA, but if you insist on having some macro insert formulas, this might be an easy approach. First put the dynamic formula you want to be pasting in to the right of the columns with a Y/N, SOMEWHERE in your sheet. In my example below I used Cell("Z1"). Make sure it's dynamic so that if you were to copy/paste formula into another cell, it would adjust correctly.
Again make sure whatever dynamic match formula you want to the right of your values is somewhere and configured to be dynamic. In my example it's on Response ws in cell Z1.
Sub Volume_Calc()
Dim Resp_WS As Worksheet: Set Resp_WS = Worksheets("ResponseFlow")
Dim CAMP_WS As Worksheet: Set CAMP_WS = Worksheets("Campaigns")
Dim rCell As Range
Dim cCell As Range
'Loops through Response Sheeet column "C" looking for values of "Y"
For Each rCell In Intersect(Resp_WS.Range("C:C"), WResp_WS.UsedRange).Cells
If UCase(rCell.Value) = "Y" Then
'When finds a cell with Y, it then loops through Campaigns Sheet column "I"
'looking for a value that matches one column to the left where the "Y" was found
For Each cCell In Intersect(CAMP_WS.UsedRange, CAMP_WS.Range("I:I")).Cells
'When match is found, the macro will insert the formula to the right
'of the cell in Campaigns, with the dynamically updated formula in cell Z1
If cCell.Value = rCell.offset(0,-1).Value Then
cCell.Offset(0, 1).FormulaR1C1 = Resp_WS.Range("Z1").FormulaR1C1
End If
Next cCell
End If
Next rCell
End Sub
I have the following VBA Function where it will find the info typed into the Input Box and deletes every row with that value.
How can I change it to delete all rows except for the value you enter. Example I enter 123. I want it to delete all rows except for the cells in column B with 123.
Sub DeleteRows()
Dim c As Range
Dim SrchRng As Range
Dim SrchStr As String
Set SrchRng = ActiveSheet.Range("B1", ActiveSheet.Range("B4343").End(xlUp))
SrchStr = InputBox("Please Enter Value")
Do
Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
OK there may well be a better way to do this but I went with creating a temp sheet, copy in the rows that match your search, clear all rows in the sheet and finally copy back the rows that matched then delete the temp sheet:
Sub DeleteRows()
Dim c As Range, b As Range, SrchRng As Range, SrchStr As String, MasterSheet As Worksheet, TempSheet As Worksheet
Set MasterSheet = ActiveSheet
Set SrchRng = ActiveSheet.Range("A1", ActiveSheet.Range("A4343").End(xlUp))
SrchStr = InputBox("Please Enter Value")
Worksheets.Add
Set TempSheet = ActiveSheet
MasterSheet.Select
Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
Set b = c
Do
If Not c Is Nothing Then
c.EntireRow.Copy
TempSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
End If
Set c = SrchRng.FindNext(After:=c)
If c.Address = b.Address Then Exit Do
Loop While Not c Is Nothing
Range("A2:A" & Rows.Count).EntireRow.ClearContents
TempSheet.Range("A2:A" & TempSheet.Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
ActiveSheet.Range("A2:A" & TempSheet.Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteAll
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = True
End Sub
Hope that helps.
I started playing around trying to populate an array from the search results in one go without looping it but it didn't go well and I have run out of spare time to explore this further unfortunately. My idea was to try and populate an array from the results in one go, then select all rows minus anything in the joined array then delete. Not sure how possible that is but maybe explore it if you get time.
My Test data was using column A, you will need to change a few parts for column B.