Excel vba copy and paste loop within loop - limit range - vba

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

Related

How to select last three row automatically on a give range in EXCEL VBA

I created a code to select and paste data from one sheet to another. But this code is always selecting last three values in row.
I need to select the data based on given range. Eg C5:C15 not for the entire c column. Help me
Private Sub CommandButton1_Click()
Dim LastRow1, LastRow2, LastRow3 As Long
Dim Last3Rows1, Last3Rows2, Last3Rows3 As Range
LastRow3 = Sheets("AVG-PO").Range("C" & Rows.Count).End(xlUp).Row
LastRow1 = Sheets("AVG-PO").Range("A" & LastRow3).End(xlUp).Row
LastRow2 = Sheets("AVG-PO").Range("B" & LastRow3).End(xlUp).Row
Set Last3Rows3 = Sheets("AVG-PO").Range("C" & LastRow3).Offset(-2, 0).Resize(3, 1)
Set Last3Rows1 = Sheets("AVG-PO").Range("A" & LastRow3).Offset(-2, 0).Resize(3, 1)
Set Last3Rows2 = Sheets("AVG-PO").Range("B" & LastRow3).Offset(-2, 0).Resize(3, 1)
Last3Rows1.Select
Selection.Copy Sheets("Data").Range("A30")
Last3Rows2.Select
Selection.Copy Sheets("Data").Range("B30")
Last3Rows3.Select
Selection.Copy Sheets("Data").Range("C30")
End Sub
Not sure i quite understand what range you want but you might be able to use this.
Sub test()
Dim NextFree As Long
Dim TableStartRange As Long
For i = 1 To 100
Select Case Range("A" & i).Value
Case "Table1"
TableStartRange = i + 1 'finds table1 in A2 and then +1 before the actual table start in column C
End Select
NextFree = Range("C" & TableStartRange & ":C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row ' returns the value 14 since its the first free row in column C
End Sub

Copying subtotal to a new worksheet in Excel using VBA

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.

Excel VBA, crashes while comparing two columns in different worksheets

I have this problem I'd like to compare two columns in one worksheet to another two columns in other worksheet and then if it's true fill other column with data.
I wrote some code but it worked only till 47 row. don't know the problem. Excel is not responding. Here's my code. Maybe someone can shed some light on what I did wrong
Sub Compare()
Dim i, j As Integer
For i = 2 To 2175
For j = 2 To 3834
If (ActiveWorkbook.Worksheets("Arkusz2").Range("B" & i) = ActiveWorkbook.Worksheets("Arkusz3").Range("A" & j) _
And ActiveWorkbook.Worksheets("Arkusz2").Range("C" & i) = ActiveWorkbook.Worksheets("Arkusz3").Range("B" & j)) _
Then ActiveWorkbook.Worksheets("Arkusz2").Range("E" & i).Value = ActiveWorkbook.Worksheets("Arkusz3").Range("C" & j).Value
Next j
Next i
End Sub
Try this. I added comments on the lines below where I made changes.
Sub Compare()
Dim i as Integer, j As Integer
' You need to specify the value type for *all* variables
Dim ws1 as Worksheet, ws2 as Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Arkusz2")
Set ws2 = ActiveWorkbook.Worksheets("Arkusz3")
' Setting these as their own variables makes the code far more readable
For i = 2 To 2175
For j = 2 To 3834
If (ws1.Range("B" & i).Value = ws2.Range("A" & j).Value _
And ws1.Range("C" & i).Value = ws2.Range("B" & j).Value) Then
' Make sure you are comparing the VALUES and not the range objects
ws1.Range("E" & i).Value = ws2.Range("C" & j).Value
Exit For
' If we've found a match, exit the inner loop early (if it *would* find
' another match, the orig. value would just be overwritten, anyways)
' This will likely reduce the time to complete significantly
End If
Next j
Next i
End Sub
Edit: Added the Exit For to quit the inner loop early after a match has been found. Credit to #Tim Williams for the suggestion.

Need to find the last row in a spreadsheet before copying and pasting data from Sheet 1 to Sheet 2

This site has helped me immensely with VBA for a while now, so thanks for that! But I just can't seem to get this code to work and I've look at so many examples. What's happening is that I'm archiving data on another sheet once the current date is 4 days ahead of the due date. Everything works like it should, but every time the macro executes, the data on sheet2 is erased and copied over. I need my code to find the last row on sheet2 and copy the data from sheet1 to sheet2 so all the data is there. Thanks!
Sub archive()
Dim LastRow As Long
Dim i As Long
LastRow = Range("M" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If Worksheets("Sheet1").Range("M" & i) - Date <= -4 And Worksheets("Sheet1").Range("N" & i).Value = "DONE" Then
Sheet2.Select
Range("A" & i).EntireRow.Value = Sheet1.Range("M" & i).EntireRow.Value
Sheet1.Range("M" & i).EntireRow.Delete
End If
If Worksheets("Sheet1").Range("L" & i) = "" Then
Exit For
End If
Next i
End Sub
Here I've taken your code and changed it to use worksheet objects. I've not tested this on any data as you haven't provided any to use, but it gives you an idea of how to implement it.
Also, in your code you weren't finding the last row of Sheet2, you were putting the data in row i, which starts at 3.
You also need to watch out when you delete the row of data from sheet1, as this shifts the rest of the data up, so the next iteration of the loop may not find the next row of data/ skip a row of data.
Sub archive()
Dim LastRow As Long
Dim LastRowSht2 As Long
Dim i As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim rowCount As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
LastRow = sht1.Range("M" & Rows.Count).End(xlUp).Row
rowCount = 3
For i = 3 To LastRow
If sht1.Range("M" & rowCount) - Date <= -4 And sht1.Range("N" & rowCount).Value = "DONE" Then
LastRowSht2 = sht2.Range("A" & Rows.Count).End(xlUp).Row + 1 '+1 so it doesn't overwrite the last row
sht2.Range("A" & LastRowSht2).EntireRow.Value = sht1.Range("M" & rowCount).EntireRow.Value
sht1.Range("M" & rowCount).EntireRow.Delete
Else
rowCount = rowCount + 1
End If
If sht1.Range("L" & rowCount) = "" Then
Exit For
End If
Next i
' clean up
set sht1 = nothing
set sht2 = nothing
End Sub

Find row value, copy row and all the range underneath for data reduction

I am trying to use a macro to clean up data files and only copy on Sheet2 what is most relevant.
I have written the code to find the row I want the data to be copied from. However I can only copy the row itself and not the range underneath. Please note I need the range to go from that row to the last column and last row as the size of the matriz always varies.
s N s N s N s N s rpm
Linear Real Linear Real Linear Real Linear Real Linear Amplitude
0.0000030 9853.66 0.0000030 5951.83 0.0000030 533.48 0.0000030 476.15 0.0000030 2150.16
0.0000226 9848.63 0.0000226 5948.19 0.0000226 557.02 0.0000226 488.60 0.0000226 2150.16
0.0000421 9826.05 0.0000421 5956.22 0.0000421 615.94 0.0000421 480.75 0.0000421 2150.15
0.0000616 9829.72 0.0000616 5989.72 0.0000616 642.59 0.0000616 476.77 0.0000616 2150.15
So basically the code below finds that first row and copies it in Sheet2. I need the macro to also select the range underneath and copy it onto Sheet2. Please can you help me finishing off the script?
Sub SearchForRawData()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
'If value in column A = "s", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "s" Then
'Select row and range in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Select all Raw Data underneath found Row to Copy
'Paste all Raw Data into Sheet 2
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error has occured"
End Sub
You don't need a loop for this if you want to copy the row that has the "s" and everything below it to the target sheet. The following sub finds the row with the "s" in column A and then copies that row and everything below it to the target sheet.
Note that you should always avoid selecting or activating anything in VBA code, and that the normal way to copy and paste relies on selecting. If you use the syntax I've included here, the clipboard is not used and the target sheet does not need to be selected.
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
' specify what we're searching for
findMe = "s"
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)
End Sub
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
So firstly you don't acutally need the CStr, vba will cast numbers to strings by itself, i.e. Range(LSearchRow & ":" & LSearchRow) should work fine.
To find how many rows down to go use the end function of the range object:
bottomRow = Range("A" & LSearchRow).End(xldown).Row
Do the same for the column
lastCol = Range("A" & LSearchRow).End(xlleft).column
Now to copy:
Range("A" & LSearchRow & ":" & lastCol & bottomRow).Copy
However if you have empty cells inthe middleof the data then instead of using End(xldown), start at the bottom of the sheet and look up:
bottomRow = Range("A1000000").End(xlup).Row
etc