I have an Excel question that comes in two parts: Firstly, if I would like to copy data from one worksheet to another where Sheet 1 has:
A
B
C
D
E
and for Sheet 2 I want every cell to repeat thrice such that when I paste the previous five cells into Sheet 2, each cell appears thrice:
A
A
A
B
B
B
C
C
C
D
D
D
E
E
E
How do I do that? I personally do now know of any formula or function that can let me do that so really looking forward to your advice.
Once that is done, is there a way to write it up using VBA? I am very very new to VBA and was just thinking if it is possible. Otherwise, I will just record a macro. Thank you very much!
With data in Sheet1 like:
In Sheet2, cell A1 enter:
=INDEX(Sheet1!A:A,ROUNDUP(ROW()/3,0))
and copy down:
( if you want 4 copies of each data item, use 4 in the formula)
a VBA way:
Option Explicit
Sub main()
Dim data As Variant, datum As Variant
Dim iDatum As Long, nTimes As Long
With Worksheets("Sheet 1") '<--| reference your "source" worksheet (change "Sheet 1" to your actual "source" sheet name
data = Application.Transpose(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Value) '<--| store its column A cells values from row 1 down to last not empty one into an array
End With
nTimes = 3 '<--| set how many times you want to copy the same value
With Worksheets("Sheet 2") '<--| reference your "target" worksheet (change "Sheet 2" to your actual "target" sheet name
.Range("A1").Resize(nTimes) = data(LBound(data)) '<--| write 1st 'data' array value 'nTimes' from its cell A1 down
For iDatum = LBound(data) + 1 To UBound(data) '<--| loop through other 'data' array values
.Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(nTimes) = data(iDatum) '<--| write them 'nTimes' from first empty row after last not empty one down
Next iDatum
End With
End Sub
Eventually, I did the old-fashioned way of doing it step by step and it worked:
LastRow = have.Cells(have.Rows.Count, "A").End(xlUp).Row
Dim p As Long
pp = 3
For p = 1 To LastRow
want.Range("A" & pp) = have.Range("A" & p).Value
pp = pp + 1
want.Range("A" & pp) = have.Range("A" & p).Value
pp = pp + 1
want.Range("A" & pp) = have.Range("A" & p).Value
pp = pp + 1
Next p
Related
I'm quite new with vba and would need your precious help.
I want to copy paste a range after the last row if I can't find a match between column B in sheet "all" and column A in sheet "FY23".
My goal is for it to copy paste the range the number of times there's not a match. So if there's 3 values not found in column B it should copy paste 3 times and with my current code it only copy pastes once...
I also want to add the values that are not found in the second cell of the first row copied, not sure how to do that either.
e.g. i can't find "hello" on column B so it will copy paste my range and add "hello" to the 2nd cell of the first row copied.
Thank you a lot in advance.
Sub copypaste()
Dim all As Worksheet, fy23 As Worksheet
Dim allLastRow As Long, fy23LastRow As Long, x As Long
Dim dataRng As Range
Set all = ThisWorkbook.Worksheets("ALL")
Set fy23 = ThisWorkbook.Worksheets("FY23")
allLastRow = all.Range("B" & Rows.Count).End(xlUp).Row
allLastRow = allLastRow + 3
fy23LastRow = fy23.Range("A" & Rows.Count).End(xlUp).Row
Set dataRng = fy23.Range("A2:A" & fy23LastRow)
For x = 2 To allLastRow
On Error Resume Next
If Not all.Range("B" & x).Value = Application.WorksheetFunction.Vlookup(all.Range("B" & x).Value, dataRng, 1, False) Then
Sheets("ALL").Range("A1:BB22").Copy
Sheets("ALL").Range("A" & allLastRow).PasteSpecial
End If
Next x
End Sub
HERE IS A NEW IMAGE HOPEFULLY SHOWING WHAT HAS TO MOVE AND WHERE'Here is a sample of some code I have been trying.
sub
For Each cel In Range("W2:W1000")
If cel.Value = "Credit Adj W/O To Collection" AND
Range("AI2:AI1000").Cells.Value > "" THEN
cel.Offset(0,-9).value =
end sub
Basically I need to look in column W for a specific text and if it is found move the number in the next column, col X over to column Y in the same row as the data in column AI, but in column Y. My issue is the amount of rows it has to move up is different based on where the data is in column AI. See screenshot
All of you have been a great help but it is still not moving any numbers. I added another screenshot. I need to look for the text in blue, if found move the amount in column X two columns right and up to the row that has a value in column AI. That gap could be different for each entry, as shown in the screen shot. could be 2 or 4 or 5, just depends on Column AI. Also first entry may not always start in the same row as it does here. The spot in column W and AI may be different throughout the spreadsheet. Hope this helps define my purpose a little.
Everyone has had great ideas but still not working, logic in answers makes sense but it is not grabbing any of the data much less move it. Not sure what is up.
Try this:
Sub tester()
Dim c As Range, ws As Worksheet, rw As Range
Set ws = ActiveSheet 'always use an explicit sheet reference
For Each c In ws.Range("W2:W1000").Cells
Set rw = c.EntireRow 'the whole row for the cell
If c.Value = "Credit Adj W/O To Collection" And _
IsNumeric(rw.Columns("X").Value) Then
'copy the value to Col Y in the row above which has a value in Col AI
ws.Cells(rw.Columns("AI").End(xlUp).Row, "Y").Value = rw.Columns("X").Value
rw.Columns("X").ClearContents ' clear the "X" value
End If
Next c
End Sub
A Tricky Column Update
Loop (r = r + 1) from the first row to the last row (the latter calculated in column W).
When column AI is not blank, write the row number to a variable (rFound).
Continue looping (r = r + 1). When column W is equal to the string Credit Adj W/O To Collection, write the value in column X of the current row to column Y of the row kept in the variable (rFound).
Continue looping (r = r + 1) by alternating between steps 2. and 3. until the last row.
Option Explicit
Sub UpdateInsAmt()
Const wsName As String = "Sheet1"
Const rStart As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rLast As Long: rLast = ws.Cells(ws.Rows.Count, "W").End(xlUp).Row
Dim r As Long: r = rStart
Dim rFound As Long
Do
If Len(CStr(ws.Cells(r, "AI").Value)) > 0 Then ' is not blank
rFound = r
r = r + 1 ' it can't be in the same row
Do
If StrComp(CStr(ws.Cells(r, "W").Value), _
"Credit Adj W/O To Collection", vbTextCompare) = 0 Then
ws.Cells(rFound, "Y").Value = ws.Cells(r, "X").Value
Exit Do ' value found and written so stop looping ...***
'Else ' value not found ...
End If
r = r + 1 ' ... so incremenet row
Loop Until r > rLast
' Else ' is blank ...
End If
r = r + 1 ' ... so increment row, ...*** and increment row
Loop Until r > rLast
End Sub
I am trying to make a macro that takes a dollar amount and percentage (2 separate columns) for a certain month's report, and add it to a historical workbook showing all of a project's dollar values/percents in the past. The code below appears to work, but actually is just pasting the next row value from the monthly report (wb1) into the next row in the historical workbook's next empty column (wb2). I need it to actually match the project names in wb1 with the project names in wb2, so that the new values actually are coming from the right project. I know it isn't working because I took out a project name to see what would happen, and the macro still posted the missing project name's information in wb2, cutting off the last value at the end of the list of projects when there weren't any more occupied cells. So, if there are 10 projects and I take out project 5, the data is posted for projects 1-9.
I also will need to add a new row if the project name in wb1 doesn't appear in wb2's column A. The new row would be for the missing project name, and would paste the dollar amount for that month. Or, at the very least, tell the user that a particular project name isn't present in wb2. I'm not sure exactly how I'll go about doing this, but I at least need the code below to add project values accurately.
Any help would be greatly appreciated!
Workbooks.Open ("T:\ADMINISTRATION\Marie Presley\HistoricalFees.xlsx")
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
'=============================================
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, n As Integer
Dim NextEmptyCol As Long
Set w1 = Workbooks("Forecast Summary Report Generator.xlsm").Worksheets("Forecast Summary")
Set w2 = Workbooks("HistoricalFees.xlsx").Worksheets("Sheet1")
NextEmptyCol = w2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
n = 0
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 3).End(xlUp).Row + n 'for each used cell in w1.colC
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w1.Cells(i, 8).Copy (w2.Cells(i, NextEmptyCol))
w1.Cells(i, 9).Copy (w2.Cells(i, (NextEmptyCol + 1)))
Exit For 'this exits the inner For loop
n = n + 1 'this would jump over the next cell(s) in w1, but never executes
End If
Next j
Next i
End Sub
I know it sounds bad, but taking Zac's suggestion, see if you can make this algorithm first with VLookup and Find worksheet functions. Even if you need to use helper sheets to handle multiple steps. It would be better if you actually knew and then saw what you wanted to do, working, before embarking on an adaption of someone else's code.
Then next try using Application.worksheetfunction to replicate the working visual sheet formulas.
After you've got this working you should be in a better place to understand the flow, and you can simplify it down into ranges and sheet objects. But until you know what the actual algorithm is or understand it, you're going to be struggling to understand what is going wrong.
Your questions title says Col A and Col A, but your code says Col C and Col A, if you need to fix the code below replace the 3 with 1. Place the NextEmptyCol within your If statement because your columns will not be the same for each row.
Remove...
NextEmptyCol = w2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
'and
For i = 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For j = 1 To w1.Cells(Rows.Count, 3).End(xlUp).Row + n 'for each used cell in w1.colC
'Find the text from w1.colC (current w1 row), within cell in w2.colA (current w2 row)
If InStr(1, w2.Cells(i, 1).Value, w1.Cells(j, 3).Value) > 0 Then
'If found then copy cell in w2.colB into cell in w2.colE (current w2 row)
w1.Cells(i, 8).Copy (w2.Cells(i, NextEmptyCol))
w1.Cells(i, 9).Copy (w2.Cells(i, (NextEmptyCol + 1)))
Exit For 'this exits the inner For loop
Replace with this...
For j= 1 To w2.Cells(Rows.Count, 1).End(xlUp).Row 'for each used cell in w2.colA
For i = 1 To w1.Cells(Rows.Count, 3).End(xlUp).Row + n 'for each used cell in w1.colC
If w2.Cells(j, 1).Value = w1.Cells(i, 3).Value Then 'find w2 values in w1
NextEmptyCol = w2.Cells(j, w2.Columns.Count).End(xlToLeft).Column + 1 'set the next empty column for each row
w2.Cells(j, NextEmptyCol).Resize(, 2).Value = w1.Cells(i, 8).Resize(, 2).Value
End If
Next j
Next i
I have 2 main ss accNo and output.
I'm trying to copy x amount of rows from AccNo to output.
The x is a variable and is determined by the user, it's inputted into cell B5 from a different ss called 'input'.
Is there a way for me to loop my code which will copy row A1, A2, A3, A4 etc from AccNo to output, (starting from A4 in output)?
I'm trying this as a macro with buttons and I'm able to do one at a time, it's just the loop I'm struggling with. I need it to loop x amount of times so for example. if x = 5 I want it to copy over 5 rows of data from accNo to output.
Sub TradingAccount()
Set accNo = ThisWorkbook.Worksheets("AccountNo")
Set output = ThisWorkbook.Worksheets("Format")
Set input = ThisWorkbook.Worksheets("input")
i = 1
e = 4
Do loop x amount of times = True
accNo.Range("A" & i).EntireRow.Copy
output.Cells(e, 1).PasteSpecial xlPasteValues '(e,1) is A4?
ActiveCell.Offset(1, 0).Select
i = i + 1
e = e + 1
Loop
End Sub
the macro will copy over x amount of rows from one spreadsheet to another.
You don't need to loop if you're using a contiguous range. Additionally, you're using values only, so we can make this a bit easier with a .value = .value such that:
dim cnt as long, lrd as long, src as worksheet, dst as worksheet
cnt = sheets("input").cells(5,2).value 'count of rows from B5 on input
set src = sheets("AccNo") 'source sheet
set dst = sheets("output") 'destination sheet
With dst
lrd = .cells(.rows.count,1).end(xlup).row 'lastrow of destination
.range(.rows(lrd+1),.rows(lrd+1+cnt-1)).value = src.range(src.rows(1),src.rows(cnt)).value 'FIXED "-1" IN SRC FINAL ROW; SEE COMMENTS
end with
Untested code, but should give the general idea. Note that cnt-1 is used, as you have a starting row (1) and you want 5 total rows (1, 2, 3, 4, 5) but adding cnt to starting row would get you to row 6.
Basically I have the following scenareo:
2 columns, with 600 rows of data.
I need to copy the data from column 2 and place it at the end of the content in column1 for the same rows. This would result in column 1 having its original content plus the additional content of column 2.
Any information in how I can do this will be greatly appreciated.
Thanks in advance!
Here's a VBA in a simple form. Just create a macro, add these lines to it. Then select your original column (what you're calling column 1), and run the macro.
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
The bracketed cell reference is a relative statement - 1, 2 means "same row, one column to the right" so you can change that if you need. You could make it loop by expanding thusly:
Do
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit Do
End If
Loop
That loop will carry on until it finds a blank cell, then it'll stop. So make sure you have a blank cell where you want to stop. You could also add extra characters into the line that combines.. so in the above example it's ActiveCell.Value = a + b, but you could make it ActiveCell.Value = a + " - " + b or anything else that may help.
This should take the values from column 2 and place them sequentially at the bottom of column 1.
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Dim r As Long
Set rng1 = Range("A1", Range("A1048576").End(xlUp))
Set rng2 = Range("B1", Range("B1048576").End(xlUp))
r = rng1.Rows.Count + 1
For Each cl In rng2
Cells(r, 1).Value = cl.Value
r = r + 1
Next
End Sub
Just keep it simple. Here is the code.
Sub copyCol()
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Range("B1:B" & lasrow).Copy Range("A" & lastRow).Offset(1, 0)
End Sub
As this question received a number of views (10,000+) I thought it was important to also share another and far simpler solution:
In cell C1 use the formula:
=(A1 & B1)
This will copy the content of cell A1 and B1 into cell C1. Drag the formula to all other rows (row 600 in my case).
Then copy the column and paste using 'values only'.
You will then have cells in column C containing the content of column A and column B in a single cell on a row-to-row basis.