I have data ranges that span couple of columns (C:D), (M:N) and (Q:R). I am trying to copy the first row in each of the series and paste it to another sheet. As in combine the ranges into a single range with the following sequence
The sequence of copy and pasting I am trying to do is
First row of range (C:D)
First row of range (M:N)
First row of range (Q:R)
Second row of range (C:D)
Second row of range (M:N)
Second row of range (Q:R)
and then the Third row and so on.. I am trying to paste the ranges into another sheet.
So far I have done this by copying each row at a time and pasting one after another. But I am finding it difficult to convert this into a loop which will copy and paste any number of rows to another sheet.
Sub CopyCol()
Sheets("Sheet10").Range("C2:D2").Copy
Sheets("Sheet11").Range("B2:C2").PasteSpecial xlPasteValues
Sheets("Sheet10").Range("M2:N2").Copy
Sheets("Sheet11").Range("B3:C3").PasteSpecial xlPasteValues
Sheets("Sheet10").Range("Q2:R2").Copy
Sheets("Sheet11").Range("B4:C4").PasteSpecial xlPasteValues
Sheets("Sheet10").Range("C3:D3").Copy
Sheets("Sheet11").Range("B5:C5").PasteSpecial xlPasteValues
Sheets("Sheet10").Range("M3:N3").Copy
Sheets("Sheet11").Range("B6:C6").PasteSpecial xlPasteValues
Sheets("Sheet10").Range("Q3:R3").Copy
Sheets("Sheet11").Range("B7:C7").PasteSpecial xlPasteValues
...
End Sub
The copy and paste does not stop there it goes on. I have just pasted a snippet of the code. The number of rows in each of the series is 45.
Is there a way to reduce the number of lines? I could not figure out how to do it using a loop.
Any help or any suggestions would be really helpful and really appreciated.
Thanks in advance.
See the following code - here's the points to take note of:
you can create the sheet and range references (wsSource, rngSource, etc) and this prevents you needing to constantly refer to Sheets("Sheet10") or Range("C2:D2") etc - this is also a good practice.
you can use other variables to define your range variables - the code below has two counters - one for the 45 rows of source data and one to track the target row in the other sheet
you need to loop through the source data, but you don't loop through the target data as you are appending to the same columns B:C and therefore just need a row counter tracking your position in the target sheet
HTH
Sub CopyCol()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rngSource As Range
Dim rngTarget As Range
Dim intSourceRowCounter As Integer
Dim intTargetRowCounter As Integer
Set wsSource = ThisWorkbook.Worksheets("Sheet10")
Set wsTarget = ThisWorkbook.Worksheets("Sheet11")
intTargetRowCounter = 1
For intSourceRowCounter = 1 To 45
Set rngSource = wsSource.Range("C" & intSourceRowCounter & ":" & "D" & intSourceRowCounter)
Set rngTarget = wsTarget.Range("B" & intTargetRowCounter & ":" & "C" & intTargetRowCounter)
rngTarget.Value = rngSource.Value
intTargetRowCounter = intTargetRowCounter + 1
Set rngSource = wsSource.Range("M" & intSourceRowCounter & ":" & "N" & intSourceRowCounter)
Set rngTarget = wsTarget.Range("B" & intTargetRowCounter & ":" & "C" & intTargetRowCounter)
rngTarget.Value = rngSource.Value
intTargetRowCounter = intTargetRowCounter + 1
Set rngSource = wsSource.Range("Q" & intSourceRowCounter & ":" & "R" & intSourceRowCounter)
Set rngTarget = wsTarget.Range("B" & intTargetRowCounter & ":" & "C" & intTargetRowCounter)
rngTarget.Value = rngSource.Value
intTargetRowCounter = intTargetRowCounter + 1
Next intSourceRowCounter
End Sub
Related
The title of the question might be a little confusing but essentially what I am trying to do is write a value to column A if Column B is not empty. This must be repeated for C through Q. The code I have now produces the desired result IF there is value in the B column. However, if there is no value for B then my replacement text will fill in all sorts of blank cells outside of the target range of A1:A. Here is the code I have:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).Formula = "=If(B1<>"""",""NEW VALUE"","""")"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
I am fairly new to VBA so please forgive any vagueness in my post.
Instead of inserting formulas and getting their values afterwards, you can do the same logic by using pure VBA:
Sub Update_Column_Based_On_Column_Value_1()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Cells(i, 2) <> "" Then
.Cells(i, 1) = "NEW VALUE"
End If
Next i
End With
End Sub
This formula will only work if A1 is the first blank.
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).Formula = "=If(B1<>"""",""NEW VALUE"","""")"
.SpecialCells(xlCellTypeBlanks) may be a discontiguous range of areas that may or may not start in row 1. You need to convert it to an xlR1C1 style formula in order to have it correctly identify the first blank row.
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE"", TEXT(,))"
TEXT(,) is the same as "" and you do not have to double-up the quotes within a quoted string; similarly, any positive number representing the length of a value in column B is the same as <>"".
I am filtering a large data set on the first sheet in my workbook and then I am creating a separate worksheet in the workbook for each unique name in the first column of the main data set.
After I filter the main data set for a given name, I am attempting to subtotal a particular filtered column (let's say column C), for example:
Sub CreateSheets()
Dim wsCurrent As Worksheet
Dim wsNew As Worksheet
Dim iLeft As Integer
Dim length As Long
Set wsCurrent = ActiveSheet
Application.ScreenUpdating = False
'Copy list of all players and remove duplicates
Range("A2", Range("A2").End(xlDown)).Copy Range("AY1")
Range("AY1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'Iterator
iLeft = Range("AY1").CurrentRegion.Rows.Count - 1
'For each player
Do While iLeft > 13
Set wsNew = Worksheets.Add
With wsCurrent.Range("A2").CurrentRegion
'Player name from copied list
.AutoFilter Field:=1, Criteria1:=wsCurrent.Range("AY1").Offset(iLeft).Value
'Hits
.AutoFilter Field:=3, Criteria1:="1"
length = .Range("C" & Rows.Count).End(xlUp).Row
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
'Turn off filters
'.AutoFilter
End With
'Name player sheet and move onto next
wsNew.Name = wsCurrent.Range("AY1").Offset(iLeft).Value
iLeft = iLeft - 1
Loop
'Clear player names in copied region
wsCurrent.Range("AY1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub
The main issue here is that the subtotal function call no longer find the referenced cell on the main sheet. Any help is much appreciated.
EDIT:
The following now provides the correct subtotal.
length = .Range("C" & Rows.Count).End(xlUp).Row
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
wsNew.Range("A1").Value = wsNew.Range("A1").Value
The last line ensures that when the filter is removed, the original sum of the visible cells remains (instead of then taking the sum of the visible cells with the filter now removed).
Have you tried including the original sheet name as a reference in the Subtotal formula?
wsNew.Range("A1") = "=SUBTOTAL(9," & wsCurrent.Name & "!C2:C" & length & ")"
I replaced 9,C2:C with 9, " & wsCurrent.Name & "!C2:C which should reference it properly.
I am trying to find out how to fill down (or copy?) a row (lastUsedRow) up to the last row. However I find myself struggling with designating ranges (especially because I am working on different datasets that have different sizes).
Before
I need to spot the lastUsedRow (lastUsedRow = .Range("A" & .Rows.Count).End(xlUp).Row) - which is row 31 here. It designates the latest row where there was data in column A.
Then I want to tell VBA to fill down until the last row (lastRow) - row 39 - which can be found using lastRow = .Range("E" & .Rows.Count).End(xlUp).Row. It designates the latest row where there was data in column E.
After
Question
VBA recommends to work with Range().FillDown but I struggle with designating the range when coding for changing datasets. More precisely, how to I write down a range that is between lastUsedRow and lastRow?
I think you want to fill down Columns A thru D, from the lastUsedRow (defined from Col A) to the lastRow (defined from Col M), using the values from lastUsedRow in columns A:D.
Dim lastRow as Long, lastUsedRow as Long
Dim srcRange as Range, fillRange as Range
With Worksheets("Sheet1")
lastUsedRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastRow = .Range("M" & .Rows.Count).End(xlUp).Row
' Fill values from A:D all the way down to lastUsedRow
Set srcRange = .Range("A" & lastUsedRow & ":D" & lastUsedRow)
Set fillRange = .Range("A" & lastRow & ":D" & lastUsedRow)
fillRange.Value = srcRange.Value
End With
If you need to preserve formatting, then use the Copy method:
srcRange.Copy Destination:=fillRange
Note: +1 to you for using See correct way to find the 'last row'
Newbee here to both this site and Excel VBA. I used RichA's code in the below post and was able to make it work well for my purpose of populating/copying data in on sheet (Sheet2) from another sheet.
CODE LINK TO ORIGINAL POST
Excel VBA Copy and Paste Loop within Loop
I have a question on how to limit the range to a 'named range' (C13:Z111) rather than the 'entire column' ("C") in this code. I cannot seem to get it to limit to copy rows, starting with last row with data and counting down to the first row.
I have some rows (C1:C12) with titles at the top and the data starts at row 13. So when copying values from one sheet to the 'other' sheet, the top rows also copy. I would like to end the copying of data at row 13.
Thank you for your help.
Here is what currently works with the exception that I am not able to limit the range.
Sub Generate_Invoice()
Dim i As Long
Dim ii As Long
Dim i3 As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("INCENTIVE")
Set sht2 = wb.Sheets("Sheet2")
Sheets("Sheet2").Select
Range("B11:Z200").ClearContents
'Find the last row (in column C) with data.
LastRow = sht1.Range("C13:C111").Find("*", searchdirection:=xlPrevious).Row
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = 3 To LastRow
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
ii = ii + 1
Next i
'Return to "Sheet2"
Sheets("Sheet2").Select
'Add SUM at bottom of last record in Range"D"
Dim ws As Worksheet
For Each ws In Worksheets
With ws.Range("F" & Rows.Count).End(xlUp).Offset(2)
.FormulaR1C1 = "=SUM(R11C6:R[-1]C6)"
.Offset(, -1).Value = "Total:"
End With
Next ws
End Sub
You were looking for the last row but only looking within the populated area. I would suggest changing the method that the last row is determined by starting at the bottom of the worksheet and finding the last populated cell in column C. This would be like being in C1048576 and tapping Ctrl+▲.
'Find the last row (in column C) with data.
LastRow = sht1.Cells(Rows.Count, "C").End(xlUp).Row
'not sure whether you want to reverse this as well
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = LastRow To 13 Step -1 'work from the bottom to the top.
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
'not sure whether you want to reverse this as well
ii = ii + 1
Next i
You just need to exit the for loop based on whatever your desired criteria is. For example:
If ii = 13 Then Exit For
So this is the concept I'm working with.
I have Sheet1 with many keys and values on it:
Then on sheet2 I have been using a SUMIF function to work out the total values from sheet1:
This is just an example and the actual datasets are much larger. I need to design a macro that will automatically generate and insert the SUMIF formula into the correct cells in sheet2. Can anyone think of a way to do this?
Even without knowing any other requirements or what you're doing or how many columns or keys there are or anything else, you can:
record a macro,
assign it to a button,
write one line of code so
that when user clicks button it will run macro on the column
selected (or when first cell of column is selected).
If there are 100+ columns then yea it's tedious and you'd want a macro to loop through it all but I have no idea what you got/need.
Here is a solution.
With [sheet1!a1:index(sheet1!a:a,count(sheet1!a:a))]
[b1:index(sheet2!b:b,count(sheet2!a:a))].Offset(1).Formula = _
"=sumif(sheet1!" & .Offset(1).Address & ",a2,sheet1!" & .Offset(1, 1).Address & ")"
End With
This assumes that the column A on sheet2 is already in place. Likewise it assumes that the Header for column B on sheet2 is already in place, and that the rest of column B is blank and will be filled by the above code.
It also assumes numeric keys.
This solution can easily be adjusted if any assumptions are wrong. Just let me know.
I would read the data up from sheet one and then build the second sheet. You will need to add a reference for the adodb recordset. In the VBA IDE on the tools pulldown menu select references. Select "Microsoft ActiveX Data Objects 2.8 Library".
Private Sub CommandButton10_Click()
Dim rs As New ADODB.Recordset
Dim ws As Excel.Worksheet
Dim lRow As Long
Dim lLastRowSheet1 As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
'Add fields to your recordset for storing data.
With rs
.Fields.Append "Row", adInteger
.Fields.Append "Key", adInteger
.Fields.Append "Val", adInteger
.Open
End With
lLastRowSheet1 = ws.UsedRange.Rows.count
lRow = 1
'Loop through and record what is in the columns
Do While lRow <= ws.UsedRange.Rows.count
rs.AddNew
rs.Fields("Row").Value = lRow
rs.Fields("Key").Value = ws.Range("A" & lRow).Value
rs.Fields("Val").Value = ws.Range("B" & lRow).Value
rs.Update
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
If rs.EOF = False Then
rs.MoveFirst
End If
'Switch to the second worksheet
Set ws = Nothing
Set ws = ActiveWorkbook.Sheets("Sheet2")
'Now go through the data from sheet one and build the list of keys
Dim iLastKey As Integer
lRow = 1
Do While rs.EOF = False
'For each unique key add a row to the second sheet.
If rs.Fields("Key").Value <> iLastKey Then
ws.Range("A" & lRow).Value = rs.Fields("Key").Value
ws.Range("B" & lRow).Formula = "=sumif(sheet1!$A$2:$A$" & lLastRowSheet1 & ",A" & lRow & ",Sheet1!$B$2:$B$" & lLastRowSheet1 & ")"
lRow = lRow + 1
End If
iLastKey = rs.Fields("Key").Value
rs.MoveNext
Loop
End Sub
This is what I used in the end:
Sub GetKeyVals()
' GetKeyVals Macro
' Get the key values based on the Unique customer codes
' Define sheet
Dim Extract As Worksheet
Set Extract = ActiveSheet
'Define lastRow
Dim lastRow As Long
lastRow = Extract.Cells(Rows.Count, "A").End(xlUp).row
' Loop round all rows
Dim n As Long
For n = 2 To lastRow
Cells(n, 3).FormulaR1C1 = _
"=SUMIF(SAPDump!R2C8:R1317C8,Extract!RC[-1],SAPDump!R2C10:R1317C10)*-1"
Range("C3").Select
Next n
' Insert Title
Dim Txt As Range
Set Txt = ActiveSheet.Range("C1")
Txt.Value = "KeyValue"
Txt.Font.Bold = True
End Sub
The problem is it's really slow, does anyone know a way of making this run any faster? cheers