I have the following Do with a nested If Not statement:
Do
Set i = SrchRng.Find("#609532", LookIn:=xlValues)
If Not i Is Nothing Then i.EntireRow.Copy
BBsheet.Activate
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
srcBook.Activate
i.EntireRow.Delete
Loop While Not i Is Nothing
This functions properly but it is failing to exit the loop when it should. When I step through it, it grabs the If Not i and skips over the copy command, but still steps through the lines below and fails on the Selection.PasteSpecial. I can not seem to get it to skip over those and move on to the next Do. The following works, but I need to copy before the delete:
Do
Set i = SrchRng.Find("#609532", LookIn:=xlValues)
If Not i Is Nothing Then i.EntireRow.Delete
Loop While Not i Is Nothing
How do I get the loop to register that "#609532" no longer exists and move on to the next loop?
You need to use If .. Then .. End If statement instead If ... Then ..:
Do
Set i = SrchRng.Find("#609532", LookIn:=xlValues)
If Not i Is Nothing Then
i.EntireRow.Copy
BBsheet.Activate
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
srcBook.Activate
i.EntireRow.Delete
End If
Loop While Not i Is Nothing
and it's better to avoid Select and Activate statements:
Do
Set i = SrchRng.Find("#609532", LookIn:=xlValues)
If Not i Is Nothing Then
i.EntireRow.Copy
With BBsheet
nextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(nextRow, 1).PasteSpecial Paste:=xlValues
End With
i.EntireRow.Delete
End If
Loop While Not i Is Nothing
Related
I am new to VBA, but had a situation where doing this manually would be extremely tedious, so I got to learning.
I needed a script that can find certain text values on a column and then copy a certain number of rows with all the row values into another worksheet. Full row values on the first row, and first 5 rows on the next rows. The text value that is searched is for example "DOL-1" or "VFD".
After lots of research and trial and error, I have managed to stitch together this script that does the job, but it is obviously badly written and not optimized. I have tried searching for similar questions and tried their answers, but I couldn't get anything to do what this script does.
I was wondering if there are some better and/or faster methods to achieve the same thing as this script does?
Sub Add_Rows()
Dim wbC As Workbook
Dim wbP As Workbook
Dim wsC As Worksheet
Dim wsP As Worksheet
Dim cell As Range
Dim r As Integer
Dim dataTable As Range
r = 8
'rownumber
Set wbP = Application.Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wsP = wbP.Worksheets("Feed_list")
' set paste destination (these variables aren't really even used because I couldn't get them to work)
Set wbC = Application.Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set wsC = wbC.Worksheets("GEN")
' set copy location (these variables aren't really even used because I couldn't get them to work)
Windows("Generated_list.xlsm").Activate
Application.ScreenUpdating = False
For Each cell In Range("AB2:AB5000")
If cell.Value = "DOL-1" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Rows(r).Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
If cell.Value = "VFD" Then
Debug.Print cell.Address
Windows("Generated_list.xlsm").Activate
Range(cell, cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
'Debug.Print r
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Rows(r).Select
Selection.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
r = r + 1
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Generated_list.xlsm").Activate
Range(cell.Offset(, -21), cell.Offset(, -25)).Copy
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
Selection.Offset(-1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
'these if functions are repeated about 20 times with different text values and number of rows copied
Next
Application.ScreenUpdating = True
Windows("Feed_list.xlsx").Activate
Sheets("Feed_list").Select
End Sub
I made small example pictures. The Generated_list looks like this. (Notice column AB)
The Feed_list looks like this at first.
And after running the script it should look like this.
Sub Main()
Call Add_Rows(8)
End Sub
Sub Add_Rows(whereToAdd As Long)
Dim wb_Feed As Workbook, wb_Gen As Workbook
Dim ws_Feed As Worksheet, ws_Gen As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, idxType As Long
Set wb_Feed = Workbooks.Open("C:\Projects\Feed_list.xlsx")
Set wb_Gen = Workbooks.Open("C:\Projects\Generated_list.xlsm")
Set ws_Feed = wb_Feed.Worksheets("Feed_List")
Set ws_Gen = wb_Gen.Worksheets("Generated_List")
' Find the last row and last column of the data in Generated List
' Assume that the first column does not contain any blank data in middle
lastRow = ws_Gen.Cells(ws_Gen.Rows.Count, "A").End(xlUp).Row
lastCol = ws_Gen.Cells(1, ws_Gen.Columns.Count).End(xlToLeft).Column ' First row is header
' Column AB is the last column
idxType = lastCol
With ws_Gen
For i = 2 To lastRow
If .Cells(i, idxType).Value = "VFD" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since VFD, insert extra 1 line according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 1
ElseIf .Cells(i, idxType).Value = "DOL-1" Then
' Insert a row to Feed List
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy entire row
.Range(.Cells(i, 1), .Cells(i, lastCol)).Copy
' Paste
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Since DOL-1 insert extra 3 lines according to your screenshot
whereToAdd = whereToAdd + 1
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
ws_Feed.Range("A" & whereToAdd).EntireRow.Insert
' Copy first 5 columns
.Range(.Cells(i, 1), .Cells(i, 5)).Copy
ws_Feed.Range("A" & whereToAdd).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 1).PasteSpecial xlPasteAll
ws_Feed.Range("A" & whereToAdd + 2).PasteSpecial xlPasteAll
Application.CutCopyMode = False
' Update where to add next
whereToAdd = whereToAdd + 3
End If
Next i
End With
' You should close the workbook after you finish your job
End Sub
I have some VBA code that works fine, however I'm trying to improve my code by losing the select commands. I am learning that this is not best practice. The (old) code that works is below:
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
If ActiveCell.Offset(0, -1).Value = 2 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("DynamicCharts").Select
Sheets("DynamicCharts").Range("E" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Data").Select
End If
next i
End With
The code switches between sheets copying and pasting using offset cells. Ive tried to change this with a WITH command and its debugging on the paste command.
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
If ActiveCell.Offset(0, -1).Value = 1 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
With Sheets("DynamicCharts")
.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Sheets("EDM Data").Select
End If
next i
End With
Any help on this would be much appreicated.
Thanks in advance
Give this a shot instead - this completely removes the need for Select. We could also get rid of Copy/Paste as well, but I need to know what you're trying to bring over (maybe it's format specific?). Please include more of your code when asking a question (like what sPeril is, etc.):
Dim destrow As Long, lastcol As Long
With Sheets("Data")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To RowCount
If Range("B" & i).Offset(0, -1).Value = 2 And Range("B" & i).Value = sPeril Then
destrow = Sheets("DynamicCharts").Cells(Sheets("DynamicCharts").Rows.Count, "E").End(xlUp).Row
lastcol = Sheets("Data").Cells(i, Sheets("Data").Columns.Count).End(xlToLeft).Column
Sheets("Data").Range(Sheets("Data").Cells(i, 2), Sheets("Data").Cells(i, lastcol)).Copy
Sheets("DynamicCharts").Range("E" & destrow + 1).PasteSpecial
End If
Next i
End With
your code but with a simple fix just look at the comment. Note I set peril to 2 just so that i can make the code fall into that condition.
Sub test2()
With Sheets("sheet1")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 1 To RowCount
Range("B1").Offset(1, 0).Select
sPeril = 2
If ActiveCell.Offset(0, -1).Value = 1 And ActiveCell.Value = sPeril Then
ActiveSheet.Cells.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
With Sheets("DynamicCharts")
'remove selection on this line.
.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
'Sheets("EDM Data").Select
End If
Next i
End With
End Sub
I receive data that is similar in content, yet varies in the number and order of columns. I installed a drop down permanently in A6, copying it to each column in row 6,of the other columns, then select the appropriate header from the list. How can I amend my macro so it would either copy the DV from A6 or create identical headers where required? (determined by countA in Row 5)
This VBA solution places text where I want the dropdowns. Please tell me what I should use to replace the text "same dropdown as A6" so that it will automatically insert a dropdown with the header choices.
Private Sub CmdSubmit_Click()
Dim i As Integer
For i = 1 To 50
ActiveSheet.Select
Range("A5").Select
If ActiveCell.Offset(0, 1).Value >= "1" Then
ActiveCell.Offset(1, 0).Select
Else
Selection.End(xlToLeft).Offset(0, 1).Select
End If
ActiveCell.Offset(0, 1).Value = "same drop down as A6"
ActiveCell.Offset(0, 2).Value = "same drop down as A6"
ActiveCell.Offset(0, 3).Value = "same drop down as A6"
ActiveCell.Offset(0, 4).Value = "Same drop down as A6"
Next i
End Sub
This works, but it is not dynamic: Can we make it dynamic?
Sub Thiscopypaste()
Dim rngcopy As Range
Dim i As Integer
Set rngcopy = ActiveSheet.Range("A6")
rngcopy.Copy
Range("B5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("C5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("D5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("E5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Range("F5").Select
If ActiveCell.Value >= "1" Then
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End Sub
If the dropdown you speak of is a data validation list then you need to perform the following:
Private Sub CmdSubmit_Click()
Dim i As Integer
Dim rngCopy As Range
For i = 1 To 50
'ActiveSheet.Select
Set rngCopy = ActiveSheet.Range("A6")
rngCopy.Copy
If rngCopy.Offset(-1, i).Value >= 1 Then
'ActiveCell.Offset(1, 0).Select
rngCopy.Offset(0, i).PasteSpecial xlPasteAll
Else
Set rngCopy = rngCopy.End(xlToLeft).Offset(0, i)
End If
'rngCopy.Offset(0, i).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 2).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 3).PasteSpecial xlPasteAll
'rngCopy.Offset(0, 4).PasteSpecial xlPasteAll
Next i
Set rngCopy = Nothing
End Sub
I am trying to put two different data sets together and it isn't working for me. Here is the code.
Sheets("Event Data").Select
Range("S:S,T:T,U:U,AA:AA,N:N").Select
Range("Table_Query_from_PostgreSQL35W[[#Headers],[site_name]]").Activate
Selection.Copy
Sheets("Staff List").Select
Range("A1:E1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Anon").Select
Range("A:A,D:D,O:O,P:P,Q:Q").Select
Range("P2").Activate
Selection.Copy
Sheets("Staff List").Select
**Range("A2:E2").Select**
ActiveSheet.Paste
Application.CutCopyMode = False
I know this is not correct. The issue I am having is selecting the first blank row (which I can do for one row) but for multiple rows (A:E). I am looking for a solution quickly. Thank you.
For the next blank row in any of A:E try,
dim nr as long
with workSheets("Staff List")
nr = application.max(.cells(.rows.count, "A").end(xlup).offset(1, 0).row, _
.cells(.rows.count, "B").end(xlup).offset(1, 0).row, _
.cells(.rows.count, "C").end(xlup).offset(1, 0).row, _
.cells(.rows.count, "D").end(xlup).offset(1, 0).row, _
.cells(.rows.count, "E").end(xlup).offset(1, 0).row)
.cells(nr, "A").paste
end with
The above code replaces the following lines of code:
Sheets("Staff List").Select
**Range("A2:E2").Select**
ActiveSheet.Paste
This is what I have:
I am trying to get excel to copy only the cells that i have selected and pasted on the next blank line in another spreadsheet.
But in the code below, it fixed the range of cell being copied. How should i change my code so that it can be a dynamic range?
Sub CopyPaste()
Range("A6:E6").Select
Selection.Copy
Sheets("Sheet2").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
End Sub
Remove the statement
Range("A6:E6").Select
This statement selects the fixed range.
Try this
Sub CopyPaste()
Dim sht As Worksheet
Dim rngTarget As Range
Dim lMaxRows As Long
Selection.Copy
Set sht = Sheets("Sheet2")
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rngTarget = sht.Range("A" & lMaxRows + 1)
rngTarget.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
sht.Activate
sht.Range("A" & lMaxRows + 1).Select
End Sub
I have rewritten the code to specify exactly which cells and ranges are used. If not, it will apply selections on the sheet that is open (active) at that moment.
In my experience, using .Select is error-prone so I try to avoid it as much as possible.