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
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
Background:
I am attempting to convert an old style of managing departments, facilities, and job titles at work to a new more convenient lookup table style format. Right now each set of data for new departments, facilities, and job titles are stored on separate sheets (a couple per week) and the sheet name is a date.
The issue:
The program runs fine for the majority of the workbook; however, I eventually get a
1004 - Application-defined or objected-defined error
When debugging, I find that my row value has to 1,048,577 and therefore caused the error. I am unsure how the iterating value is escaping my handling of it.
The code:
Sub cleanUp()
Dim wks As Worksheet
Dim wksNum As Long
Dim destWks As Worksheet
Dim rng As Range
Dim row As Long
Dim col As Long
Dim destRow As Long
Dim lastRow As Long
Dim itemType As String
Set destWks = ActiveWorkbook.Sheets("new")
destRow = 2
For wksNum = 1 To ActiveWorkbook.Sheets.Count
NextWks:
Set wks = ActiveWorkbook.Worksheets(wksNum)
If wks.Name = "new" Then
wksNum = wksNum + 1
GoTo NextWks
End If
lastRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).row
For row = 1 To lastRow
NextRow:
Select Case wks.Cells(row, 1).Value
Case "New Hospitals"
itemType = "Hospital"
row = row + 1
GoTo NextRow
Case "New Departments"
itemType = "Department"
row = row + 1
GoTo NextRow
Case "New Job Titles"
itemType = "Job Title"
row = row + 1
GoTo NextRow
Case "none"
row = row + 1
GoTo NextRow
Case ""
row = row + 1
GoTo NextRow
End Select
destWks.Cells(destRow, 1).Value = wks.Name
destWks.Cells(destRow, 2).Value = itemType
wks.Range("A" & row & ":C" & row).Copy destWks.Range("C" & destRow)
destRow = destRow + 1
Next row
Next wksNum
End Sub
Example Sheet:
New Hospitals
None
New Departments
10 146 7205-DeptA
10 193 9178-DeptB
New Job Titles
004315 JobTitleA
A side question:
Is there a more elegant way of skipping to the next iteration of a for loop without using a GoTo statement. My thoughts are that these are causing my issue.
Thank you for any and all help.
The problem is if your data on any sheet ends with either of the group headings or none then it will start an eternal loop adding 1 to row until it reaches a row number that is not supported by the worksheet.
You have taken the loop outside the For Loop and so it does not stop.
It is better to test for the opposite and do the code instead of using the archaic Goto.
Use this:
Sub cleanUp()
Dim wks As Worksheet
Dim wksNum As Long
Dim destWks As Worksheet
Dim rng As Range
Dim row As Long
Dim col As Long
Dim destRow As Long
Dim lastRow As Long
Dim itemType As String
Set destWks = ActiveWorkbook.Sheets("new")
destRow = 2
For wksNum = 1 To ActiveWorkbook.Sheets.Count
Set wks = ActiveWorkbook.Worksheets(wksNum)
If wks.Name <> "new" Then
lastRow = wks.Cells(wks.Rows.Count, 1).End(xlUp).row
For row = 1 To lastRow
Select Case wks.Cells(row, 1).Value
Case "New Hospitals", "New Departments", "New Job Titles"
itemType = Replace(wks.Cells(row, 1).Value, "New ", "")
Case "None", ""
Case Else
destWks.Cells(destRow, 1).Value = wks.Name
destWks.Cells(destRow, 2).Value = itemType
wks.Range("A" & row & ":C" & row).Copy destWks.Range("C" & destRow)
destRow = destRow + 1
End Select
Next row
End If
Next wksNum
End Sub
Edited to simplify Select Case based on Scott Holtzman's now deleted answer
Output with provided data:
I have a string array that i want to insert as a new row at the end of the sheet using xlDown.
Iv'e tried Range("A1:A" & UBound(strArr) + 1) = WorksheetFunction.Transpose(strArr)
But it copies that to a column and not to the lowest row..
Thanks for helping.
You need to Resize the Range to size of the array (you need to modify the Column dimension). Since the array starts at 0, and Column starts at 1 we add 1, so the syntax is: Range("A" & LastRow + 1).Resize(, UBound(strArr) + 1).Value.
Second, LastRow finds the last row with data (in Column A), so we +1 to write the result on the next empty row (1 row below).
Try the code below:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row '<-- get last row in Column A
Range("A" & LastRow + 1).Resize(, UBound(strArr) + 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(strArr))
Using this, this will ensure you are getting last row of the sheet as anything that is detected will make that the last row.
lastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & lastrow).Resize(, UBound(strArr)).Value = WorksheetFunction.Transpose(strArr)
Option Explicit
Public Sub TestMe()
Dim strArr As Variant
strArr = Array("a", "b", "c")
Range("A" & last_row + 1 & ":A" & last_row + UBound(strArr) + 1) = WorksheetFunction.Transpose(strArr)
End Sub
Public Function last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long
Dim shSheet As Worksheet
If str_sheet = vbNullString Then
Set shSheet = ThisWorkbook.ActiveSheet
Else
Set shSheet = ThisWorkbook.Worksheets(str_sheet)
End If
last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row
End Function
The trick is that you should find the last row and then use the size of the array to calculate the size of the new range.
Like this:
Range("A" & last_row + 1 & ":A" & last_row + UBound(strArr) + 1) = WorksheetFunction.Transpose(strArr)
This code in its current setting copies row 5 in all sheets to a master sheet. i need it to pull up a random row in a range.
Sub test()
Dim curRow As Integer
Dim activeWorksheet As Worksheet
Set activeWorksheet = ActiveSheet
curRow = 1
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Name = activeWorksheet.Name Then
ws.Range("5:6").Copy Destination:=activeWorksheet.Range(CStr(curRow) & ":" & CStr(curRow) + 1)
curRow = curRow + 1
End If
Next ws
End Sub
I tried wring the random code like this but it failed with runtime error 1004
Sub test()
Dim curRow As Integer
Dim activeWorksheet As Worksheet
Set activeWorksheet = ActiveSheet
curRow = 1
rndnum = Int((50 - 30 + 1) * Rnd + 1)
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Name = activeWorksheet.Name Then
ws.Range("(rndnum):(rndnum+1)").Copy Destination:=activeWorksheet.Range(CStr(curRow) & ":" & CStr(curRow) + 1)
curRow = curRow + 1
End If
Next ws
End Sub
If you want to use variables in Range, do it like this:
'if you only want to use Rows
Range(var1 & ":" & var2)
'if you want to refer to a cell
Range(Cells(varRow,varColumn))
You were pretty close. One of the row references was working (although the CStr conversion was unnecessary); the other was malformed.
Sub test()
Dim curRow As Long, rndNum As Long, ws As Worksheet
With ActiveSheet
curRow = 1
rndNum = Int((50 - 30 + 1) * Rnd + 1)
For Each ws In .Parent.Worksheets
If Not ws.Name = .Name Then
ws.Range(rndNum & ":" & rndNum + 1).Copy _
Destination:=.Range(curRow & ":" & curRow + 1)
curRow = curRow + 2
End If
Next ws
End With
End Sub
I've also added a With ... End With statement to reduce the redundant calls to the var assigned to the ActiveSheet property. The ws var should have been declared.