I need help with loop code to copy one cell from column R and paste into next empty cell in column C.
column C
12345
12345
12345
(paste 1 in here)
12346
12346
(paste 2 in here)
12347
12347
12347
12347
(paste 3 in here)
Column R
1
2
3
I used this code but when I will have 500 records it seems impossible to repeat this code for 500 times.
Range("R2").Select
Selection.Copy
Range("C1").Select
If IsEmpty(ActiveCell.Offset(1, 0)) Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.End(xlDown).Offset(1, 0).Select
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Try this:
Option Explicit
Public Sub CopyAndPaste()
Dim colToPaste As New Collection
Dim rngCell As Range
With Worksheets(1)
For Each rngCell In .Range("B1:B5")
colToPaste.Add rngCell
Next rngCell
For Each rngCell In .Range("A1:A500")
If IsEmpty(rngCell) Then
If colToPaste.Count = 0 Then Exit Sub
rngCell = colToPaste(1)
colToPaste.Remove (1)
End If
Next rngCell
End With
End Sub
In general, this is what we have:
a collection colToPaste, which contains all the values of the range B1:B5. You can change the collection range and make it with variable, as per the last row in column B. See here - https://www.rondebruin.nl/win/s9/win005.htm
A loop going through the range A1:A500, which would check for every cell, whether it is empty or not. If it is empty, it would give it the value of the first one in the list like this - rngCell = colToPaste(1). Then it would remove it.
In order to know when to stop, I have added If colToPaste.Count = 0 Then Exit Sub. The =0 part can be removed, but it is easier to understand it this way.
Related
I have this code to paste content in my table, but I want it to work correctly when I'm not in a specific cell in the current row, because it always returns a fixed cell number to paste the content, so I would like help to know how I modify this code so that it pastes the contents in the current line but instead of using ActiveCell.Offset(0, -3) , use something that would: Paste in the cell of the current row that is part of the column [Plano de Contas].
My current code:
Sub COLAR_CC()
ActiveCell.Offset(0, -3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End Sub
Table for reference:
I think this may start you off:
Option Explicit
Sub sub1()
Dim icol&
icol = FindCol("ColTwo") ' find column
Cells(3, icol) = "Got it"
End Sub
Function FindCol&(txt$) ' find column
Dim iErr&
On Error Resume Next
FindCol = Rows(1).Find(txt, , xlValues, xlWhole, xlByColumns, xlNext, True).Column
If Err.Number <> 0 Then Stop ' handle error
On Error GoTo 0
End Function
I am trying to write a macro that copies data from a form (Contractor Entry Form, range "U5:AT5") and pastes it to a database (CONTRACTOR DATABASE).
When a record is edited, it requests the Employee ID# and finds that row on the database, and pastes that row number reference temporarily into cell Contractor Entry Form "L1".
I need to then paste the copied data to the database on that row number (-1) that is referenced in cell "L1". If there is no value in "L1" that means it is a new entry and should then just paste to the last row -- as opposed to pasting over a previous record row.
Help, please. My code is here--
Sub ContractorEntry
Range("U5:AT5").Copy
Sheets("CONTRACTOR_DATABASE").Select
Dim R As Integer
R = Worksheets("CONTRACTOR ENTRY").Range("L1").value
'note-- if there is a value in CONTRACTOR ENTRY L1>0 then
' (it represents a row number --- paste value to that row -1 onto
' Contractor Database sheet.
If Worksheets("CONTRACTOR ENTRY").Range("L1") > 0 Then
Sheets("CONTRACTOR_DATABASE").Cells (R -1, 1)
Selection.PasteSpecial
End If
Else
'if there is no value in cell L1 then the following to just paste to the next blank row
lMaxRows = Cells(Rows.Count, "A").End(xlUpSelection.PasteSpecial.Row
Range("A" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks :=False, Transpose:=False
'This returns to the contractor entry form and clears contents
Sheets("CONTRACTOR ENTRY").Select
Range("D3:M1").Select
Selection.ClearContents
'Should go back to Contractor Entry Form for Name and a new entry in cell D3
Range("D3").Select
End Sub
There's almost never any need to use Select/Activate see here for guidelines on how to improve your code: How to avoid using Select in Excel VBA
Something like this should work:
Sub ContractorEntry()
Dim rw, wsInput As Worksheet, wsDB As Worksheet
'use worksheet varaibles for easier maintenance
Set wsInput = ThisWorkbook.Worksheets("CONTRACTOR ENTRY")
Set wsDB = ThisWorkbook.Worksheets("CONTRACTOR_DATABASE")
rw = wsInput.Range("L1").Value - 1
'if row not present then get next empty row
If rw < 1 Then rw = wsDB.Cells(Rows.Count, "A").End(xlUp).Row + 1
'copy over values directly (no copy/paste)
With wsInput.Range("U5:AT5")
wsDB.Cells(rw, "A").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
With wsInput
.Activate
.Range("D3:M1").ClearContents
.Range("D3").Select
End With
End Sub
i need a simple vba code. I hope someone can help me.
So, I want to copy the range B2:E6 and leave some cells marked with a special condition. I created a rule in cells A2:A6 with the value Y / X. In the end, I want to paste the value B2:E6 in the range F9:I13 only if the value is Y.
I am attaching the following image to make it easier for you to understand.
Any help will be great. And sorry my english is bad.
Maybe this can get you started
Sub Macro1()
Dest = 8
For Row = 1 To 6
If Cells(Row, 1) <> "x" Then
Range(Cells(Row, 2), Cells(Row, 5)).Select
Selection.Copy
Cells(Dest, 6).Select
ActiveSheet.Paste
End If
Dest = Dest + 1
Next Row
End Sub
I recommend that you first define your working worksheet, if the CommandButton1 button code linked to the CommandButton1_Click() event, showen in your code, is not associated with your working sheet (Sheet9). Otherwise, the code will be executed on another Sheet than Sheet9, on which you want the conditions to be fulfilled.
So, I suggest this code, that formats also the target table "(F8:I13)":
Private Sub CommandButton1_Click()
Dim myWorkingSheet As Worksheet
Dim Working_Range As Range, Target_Range As Range
Dim Line_to_Read As Double, Table_Shift As Double
Set myWorkingSheet = Sheets("Sheet9")
myWorkingSheet.Activate
' Copy the header table
myWorkingSheet.Range("B1:E1").Copy Range("F8")
Application.CutCopyMode = False
' Copy the format of the table
myWorkingSheet.Range("B1:E6").Copy
myWorkingSheet.Range("F8").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' Copy table if current cell in column A = "y"
Set Working_Range = myWorkingSheet.Range("A2:A6")
Line_to_Read = 2
Table_Shift = 7 'To start at F9 cell
For Each wr In Working_Range
If wr = "y" Then
myWorkingSheet.Range(Cells(Line_to_Read, 2), Cells(Line_to_Read, 5)).Copy myWorkingSheet.Range(Cells(Line_to_Read + Table_Shift, 6), Cells(Line_to_Read + Table_Shift, 10))
End If
Line_to_Read = Line_to_Read + 1
Next
' To point the cursor at the first cell.
myWorkingSheet.Cells(1, 1).Select
End Sub
To avoid the repetition of myWorkingSheet in the you use With clause and End With.
I'm relatively new to VBA and have some code I wrote that seems like it should be straightforward but is not behaving as expected. I am trying to separate my primary WorkSheet (GAWi) into three other worksheets (LWi, WMi, & OTi) based on the first letter in column H. Basically if the first letter is "L" I want that row to be copied and pasted onto sheet LWi and then deleted from the original sheet. Then if it is W it goes onto WMi and if it is A it goes onto OTi. It is functioning properly for the first two If statements (placing items that begin with L & W onto the correct sheets), but for the last one items that begin with P and 0 are also being placed onto sheet OTi. I'm at a complete loss, it seems pretty easy and I can't figure out where I went wrong. Any advice would be much appreciated, also I'm sure this code is pretty unelegant by most standards so any tips on how to shorten it would also be welcomed-I've just started getting into VBA in the last couple weeks. Thank so much!
Sheets("GAWi").Select
Columns("H:H").Select
Dim lwr As Range
Set lwr = ActiveSheet.UsedRange
For i = lwr.Cells.Count To 1 Step -1
If Left(lwr.Item(i).Value, 1) = "L" Then
lwr.Item(i).EntireRow.copy
Sheets("LWi").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Sheets("GAWi").Select
lwr.Item(i).EntireRow.Delete
End If
If Left(lwr.Item(i).Value, 1) = "W" Then
lwr.Item(i).EntireRow.copy
Sheets("WMi").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Sheets("GAWi").Select
lwr.Item(i).EntireRow.Delete
End If
If Left(lwr.Item(i).Value, 1) = "A" Then
lwr.Item(i).EntireRow.copy
Sheets("OTi").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Sheets("GAWi").Select
lwr.Item(i).EntireRow.Delete
End If Next i
there's a main flaw in your logic: the use of UsedRange
despite being it a 2D range, its Item() property would act as if it were a 1D array with one row listed after another
so that were "A1:H10" (eight columns) the address of UsedRange, UsedRange.Item(1) would point to "A1", UsedRange.Item(8) would point to "H1" and UsedRange.Item(9) would point to "A2" …
so you have to loop through the cells of column H only
Then there's a coding flaw, which is the use of all those Select/Selection: get in the habit of always use explicit range reference qualified up to their parent worksheet and workbook
. This can be reached, for instance, with the use of With... End With construct
here's a possible code (explanations in comments):
Option Explicit
Sub TransferRows()
Dim i As Long
With Sheets("GAWi") ' reference "source" sheet
For i = .Cells(.Rows.Count, "H").End(xlUp).Row To 1 Step -1 ' loop backwards from referenced sheet column H last not empty cell row index to 1
Select Case UCase(.Cells(i, "H").Value) ' check for referenced sheet column H current row content
Case "L"
TransferRow Intersect(.UsedRange, .Rows(i)), Sheets("LWi") ' pass referenced sheet current row "used" range and "LWi" destination sheet to the helper sub
Case "W"
TransferRow Intersect(.UsedRange, .Rows(i)), Sheets("WMi") ' pass referenced sheet current row "used" range and "WMi" destination sheet to the helper sub
Case "A"
TransferRow Intersect(.UsedRange, .Rows(i)), Sheets("OTi") ' pass referenced sheet current row "used" range and "OTi" destination sheet to the helper sub
End Select
Next i
End With
End Sub
Sub TransferRow(sourceRng As Range, destSht As Worksheet)
With destSht
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, sourceRng.Columns.Count).Value = sourceRng.Value
End With
sourceRng.Delete xlUp
End Sub
As you see, other than the amendements due to the preface explanations I put in there:
the use of Select Case syntax instead of If Then End If
which I think is much clearer and would also correct a minor logic flaw of your orginal code: once a check is positive there's no need to run other ones (this you could have obtained by means of If - Then - ElseIf - Endif construct)
the use of a "helper" sub to demand the repetitive code to
which gives you much more control over your code and helps its maintenance
the use of Cells(Rows.Count, colIndex).End(xlUp) pattern
which is the most frequently used one to get the reference to the last not empty cell in some colIndex (be it a number or a letter) column
Thanks to HTH's great response I was able to clean up my code a bit and think I got it figured out. I opted to stick with the If Then Else If format since I am not too familiar with using Case yet. Here's the first section of it, I just repeated the copy, paste, delete row for each starting letter.
Set rng = Range("GAWi!H:H")
For k = rng.Cells.Count To 1 Step -1
If Left(rng.Item(k).Value, 1) = "W" Then
With rng.Item(k)
.EntireRow.copy
Sheets("WMi").Activate
ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.EntireRow.Delete
End With
ElseIf Left(rng.Item(k).Value, 1) = "L" Then....
This is running well for my purposes but if anyone has more suggestions they are much appreciated.
VBA code which finds the last non empty cell of Row 5, copies the data till that cell of Row 5 and pastes that data as values after transposing. I tried to record a macro by copying the data but it didn't work.
I'm assuming you're talking about excel vba. The below code copies from a range in sheet1 column A, down to the last data in the row ( you can change this to be only to row 5 if you have data after 5 that you don't want to copy). Then it transposes it on to sheet2.
update to only go to 5
Sub someMacro()
Dim answerRange As Range
Dim checkBlankRange As Range
Dim lastRowInRange As Long
Dim lastcolumn As Long
Set checkBlankRange = Worksheets("Sheet1").Range("A1:A5") 'changed to 1 to 5
lastRowInRange = 5 ' default to 5
lastcolumn = Sheets("Sheet1").Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
'or you can use line below for last column
'lastcolumn = Sheets("Sheet1").Cells(1, Sheets("Sheet1").Columns.Count).End(xlToLeft).Column
For Each cell In checkBlankRange
If cell.Value = "" Then 'first empty cell
lastRowInRange = cell.row 'get the row number of the empty cell
Exit For
End If
Next cell
Set answerRange = Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 1), Sheets("Sheet1").Cells(lastRowInRange, lastcolumn))
answerRange.Copy
ActiveWorkbook.Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub
if the data is always going to be in those colums you wont need alot of the code and you can just use what you had in your recorded macro - cleaned up to remove selects
Sub simpleVersion()
Sheets("Sheet1").Range("A1:F5").Copy
Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub