In the pictures below, I have a source page that is formatted with a device and attributes. I would like to create a macro which copies that source data and pastes it in the format of the target sheet. Ultimately the target sheet would be empty and would populate only when running the macro.
Source page and target page
I am a newb at this. I've tried using the following code from another stack overflow question, but it doesn't do what I want.
Sub ColumnCopy()
Dim lastRow As Long
Dim lastRow As Long
Dim lastCol As Long
Dim colBase As Long
Dim tRow As Long
Dim source As String
Dim target As String
source = "source" 'Set your source sheet here
target = "target" 'Set the Target sheet name
tRow = 2 'Define the start row of the target sheet
'Get Last Row and Column
lastRow = Sheets(source).Range("A" & Rows.Count).End(xlUp).Row
lastCol = Sheets(source).Cells(2, Columns.Count).End(xlToLeft).Column
tRow = 2
colBase = 2
Do While colBase < lastCol
For iRow = 2 To lastRow
Sheets(target).Cells(tRow, 1) = Sheets(source).Cells(1, tRow)
Sheets(target).Cells(tRow, 2) = Sheets(source).Cells(2, tRow)
Sheets(target).Cells(tRow, 3) = Sheets(source).Cells(3, tRow)
Sheets(target).Cells(tRow, 4) = Sheets(source).Cells(4, tRow)
Sheets(target).Cells(tRow, 5) = Sheets(source).Cells(5, tRow)
Sheets(target).Cells(tRow, 6) = Sheets(source).Cells(6, tRow)
tRow = tRow + 1
Next iRow
colBase = colBase + 1 'Add 4 to the Column Base. This shifts the loop over to the next Row set.
Loop
End Sub
Thanks,
MJ
Related
The code that I have currently pastes the data in Column A of worksheet "Projects" into the next blank row on worksheet "Assignment". I would like it to paste into the first blank cell on worksheet "Assignment" instead.
Option Explicit
Sub CopyPasteX()
'Declare variables
Dim projName As String
Dim projCount As Integer, lRow As Integer, lRow2 As Integer, i As Integer, j As Integer
'Find last row
lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row
'Begin loop - CHANGE BELOW FROM 2 TO 1 IF SPREADSHEET DOES NOT INCLUDE HEADDERS
For i = 2 To lRow
'Set project names and the project count
projName = Sheets("Projects").Range("A" & i)
projCount = Sheets("Projects").Range("B" & i)
'Second loop for pasting in project
For j = 1 To projCount
'Find last row on sheet 2
lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row
'Paste in the project name on sheet2
Sheets("Assignment").Range("A" & lRow2 + 1).Value = projName
'Loop to continue copying based on the project count
Next j
'Loop to next project
Next i
End Sub
Edit: I amended the lRow2 definition and refactored the whole code to take advantage of With ... End With sintax and reference proper sheet
Sub CopyPasteX()
'Declare variables
Dim lRow2 As Integer, j As Long
Dim cell As Range
With Sheets("Projects") 'reference wanted sheet
'loop through referenced sheet column A cells from row 1 down to last not empty one
'Begin loop - CHANGE BELOW FROM "A2" TO "A1" IF SPREADSHEET DOES NOT INCLUDE HEADDERS
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Second loop for pasting in project, taking current cell adjacent one as the ending value
For j = 1 To cell.Offset(, 1)
'Find firts empty cell on sheet Assignment
With Sheets("Assignment")
Select Case True
Case IsEmpty(.Range("A1"))
lRow2 = 0
Case WorksheetFunction.CountA(.Range("A1", .Cells(.Rows.Count, "A").End(xlUp))) = 1
lRow2 = 1
Case Else
lRow2 = .Range("A1").End(xlDown).row
End Select
.Range("A" & lRow2 + 1).Value = cell.Value 'Paste current cell value (i.e. project name) in referenced sheet column A at row lRow
End With
'Loop to continue copying based on the project count
Next
'Loop to next project
Next
End With
End Sub
'Find last row on sheet 2
lRow2 = Sheets("Assignment").[A1].End(xlDown).Row
I found that this works exactly how I need it to.
Edit: This does not work as noted in the reply.
No need for inner loop. Try this code
Sub CopyPasteX()
Dim projName As String
Dim projCount As Integer
Dim lRow As Integer
Dim lRow2 As Integer
Dim i As Integer
lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
projName = Sheets("Projects").Range("A" & i)
projCount = Sheets("Projects").Range("B" & i)
lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row
lRow2 = IIf(lRow2 = 1, 1, lRow2 + 1)
Sheets("Assignment").Range("A" & lRow2).Resize(projCount).Value = projName
Next i
End Sub
Another code (using arrays)
Sub Test()
Dim arr As Variant
Dim temp() As String
Dim i As Long
Dim j As Long
Dim k As Long
arr = Sheets("Projects").Range("A2:B" & Sheets("Projects").Cells(Rows.Count, 1).End(xlUp).Row).Value
j = 1: k = 1
For i = 1 To UBound(arr, 1)
k = k + arr(i, 2)
ReDim Preserve temp(1 To k)
For j = j To k
temp(j) = arr(i, 1)
Next j
j = k
Next i
With Sheets("Assignment").Range("A1")
.Resize(k - 1, 1).Value = Application.Transpose(temp)
End With
End Sub
I need help to copy and paste a single row for every cell in another column multiple times starting in the second row.
The raw data looks like this
I need it to look like this
ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:="=Sheet2!R2C5:R2C7"
ActiveWorkbook.Names("data1").Comment = "" Range("data1").Copy
Range("B1").Select ActiveCell.Offset(1, 0).Select ActiveCell.PasteSpecial
Here is where I get lost. I am not sure how to loop it down and then keep it going and copy column a down and then the defined range again.
I also tried this:
Dim LastRow As Variant
Dim LastRowA As Variant
Dim Row As Range
Dim i As Integer
With Sheets("Store_Item_copy")
LastRow = .Range("A2" & Row.Count).End(xlUp).Row
End With
Range("A2" & LastRow).Copy
For i = 2 To LastRow
i = i + 1
With Sheets("Store_Item_copy")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
End With
LastRowA.Offset(1, 0).Select
ActiveCell.PasteSpecial
Next i
Here is one way to do it using arrays.
Option Explicit
Public Sub PopulateColumns()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1") 'Change as appropriate
Dim yearArr()
yearArr = wsSource.Range("E2:F" & wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row).Value
Dim storesArr()
storesArr = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value
Dim resultArr()
ReDim resultArr(1 To UBound(storesArr, 1) * UBound(yearArr, 1), 1 To 3)
Dim counter As Long
Dim counter2 As Long
Dim x As Long, y As Long
For x = 1 To UBound(yearArr, 1)
counter2 = counter2 + 1
For y = 1 To UBound(storesArr, 1)
counter = counter + 1
resultArr(counter, 1) = storesArr(y, 1)
resultArr(counter, 2) = yearArr(counter2, 1)
resultArr(counter, 3) = yearArr(counter2, 2)
Next y
Next x
wsSource.Range("A2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
End Sub
I got the following code, which is supposed to
1) Search for my word, copy and paste the entire row that contains the word into new sheet
2) Search for a word after the 1st, then copy and paste that entire row beside the contents of 1) in the new sheet.
Could someone take a look, I am having trouble actually getting the results, there is no error I am getting. So I assume it is the whole copy and paste to my new sheet name. However i am not 100% sure.
Sub stack()
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("stack:")) Then
StrX = Range(Cells(NSLRow + 1, 1), Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("overflow:")) Then
StrX = Range(Cells(NSLRow + 1, 7), Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
EDIT, Expected result:
!http://i.imgur.com/69elWuB.jpg
EDIT, updated code with some fixes you guys mentioned.
Sub stackv2()
'added Sheets(OSheets)to Range Cells
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("first name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 1), Sheets(OSheet).Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 7), Sheets(OSheet).Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
This will work for your example:
Sub stackv2()
Dim OSheet As Worksheet
Dim NSheet As Worksheet
Dim i As long
Dim LRow As long
Dim NSLRow As Long
Dim cpyClm As Long
Set OSheet = Sheets("Sheet1") 'change to your Old Sheet Name
Set NSheet = Sheets("Sheet7") 'change to your New Sheet Name
cpyClm = 1 'change this to the number columns desired
'Finds last row in the New Sheet
NSLRow = NSheet.Cells(NSheet.Rows.Count, 1).End(xlUp).Row
With OSheet
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
For i = 2 To LRow
'If cell has "First Name then..."
If InStr(LCase(.Cells(i, 1)), LCase("first name")) Then
NSLRow = NSLRow + 1 'moves to new row every time this is true.
NSheet.Cells(NSLRow, 1).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
NSheet.Cells(NSLRow, 1 + cpyClm).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("middle name")) Then
NSheet.Cells(NSLRow, 1 + (cpyClm * 2)).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
End If
Next i
End With
End Sub
But because we don't know what your true data looks like I put the ability to change the number of columns to copy. Also since your example does not include column A, and your explanation wants it you will need to change the column in the cells to 1 instead of 2
If this does not work or help you figure out how to adjust it on your own, you will need to post an actual representation of your data and desired output.
I'm generating a "random" (with no repeats) list of the questions using the following:
Sub randomCollection()
Dim Names As New Collection
Dim lastRow As Long, i As Long, j As Long, lin As Long
Dim wk As Worksheet
Set wk = Sheets("Sheet1")
With wk
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To lastRow
Names.Add wk.Cells(i, 1).Value, CStr(wk.Cells(i, 1).Value)
Next i
lin = 1
For i = lastRow - 1 To 1 Step -1
j = Application.WorksheetFunction.RandBetween(1, i)
lin = lin + 1
Range("B" & lin) = Names(j)
Names.Remove j
Next i
End Sub
I'm stuck on how to pick up data in column B, and generate it with the corresponding data in column A.
For example, A1 and B1 need to stay together on the "random" list, as does A2, B2, etc.
If I understand your task correctly, you want to take whatever is in column A and put it in column B in random locations, not including a header row. If this is the case, try this:
Sub randomCollection()
Dim wrk As Worksheet, source As Long, dest As Long, lastRow As Long, i As Long, rowCount As Long
Set wrk = ActiveWorkbook.ActiveSheet
lastRow = wrk.Rows.Count
lastRow = wrk.Range("A1:A" & Trim(Str(lastRow))).End(xlDown).Row
'First, clear out the destination range
wrk.Range("B2:B" + Trim(Str(lastRow))).Clear
source = 2
Do Until source > lastRow
dest = Application.WorksheetFunction.RandBetween(1, lastRow - source + 1)
'Find the blank row corresponding to it
rowCount = 1
For i = 2 To lastRow
If dest = rowCount And wrk.Cells(i, 2) = "" Then
wrk.Cells(i, 2) = wrk.Cells(source, 1)
Exit For
End If
If wrk.Cells(i, 2) = "" Then '2 is column B
rowCount = rowCount + 1
End If
Next
source = source + 1
Loop
End Sub
This looks for the first random blank space in column B to put each cell in column A.
I have the below code that works great. It parses through all my sheets and finds the row in column A that I want and pastes it to a specified worksheet. However, I need it to copy the specified row plus the next X number of rows. Can someone help me accomplish this?
Sub FindValues()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Integer
For Each ws In Application.ThisWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= LastRow
If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
ws.Rows(i).Copy Sheets("Summary").Range("A2")
i = i - 1
LastRow = LastRow - 1
End If
i = i + 1
Loop
Next
End Sub
You can amend the range of rows being copied on this line like so:
ws.Rows(i & ":" & i + 3).Copy Sheets("Summary").Range("A2")
If the match was found in row 1 for example, the code would render as ws.Rows(1:4).Copy
I have done some minor modifications. Just added (i + number of rows to be copied). Check the below code:
Used Integer copyrw in the code, you can set this integer to copy the number of rows.
Sub FindValues()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Integer
Dim copyrw as Integer
copyrw = 3
For Each ws In Application.ThisWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= LastRow
If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
ws.Rows(i & ":" & i + copyrw).Copy Sheets("Summary").Range("A2")
i = i - 1
LastRow = LastRow - 1
End If
i = i + 1
Loop
Next
End Sub