I'm a total novice with VBA. I have the following code which does a matching exercise and then pastes the relevant values into col. B. my issue is each time the code is used the col will change how can I add this to the module so that it looks for the last cell used in row 1 and pastes the values below.
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Application.ScreenUpdating = False
lastrow1 = Sheets("Input Sheet").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = Sheets("Input Sheet").Cells(i, "B").Value
Sheets("Data").Activate
lastrow2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Data").Cells(j, "A").Value = myname Then
Sheets("Input Sheet").Activate
Sheets("Input Sheet").Cells(i, "c").Copy
Sheets("Data").Activate
Sheets("Data").Cells(j, "B").Select
ActiveSheet.PasteSpecial
End If
Next j
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
End Sub
any assistance with this would be appreciated.
You can replace your second For j = 2 To lastrow2 with the Match function.
Also, there is no need to Activate the sheets back and fourth all the time, just use fully qualified Ranges instead.
Code
Option Explicit
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim MatchRng As Range
Application.ScreenUpdating = False
j = 2
With Sheets("Input Sheet")
lastrow1 = .Range("B" & .Rows.Count).End(xlUp).Row
' the 2 lines bellow should be outisde the loop
lastrow2 = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
Set MatchRng = Sheets("Data").Range("A2:A" & lastrow2)
For i = 2 To lastrow1
myname = .Range("B" & i).Value
If Not IsError(Application.Match(myname, MatchRng, 0)) Then '<-- if successful Match
Sheets("Data").Range("B" & j).Value = .Range("C" & i).Value
j = j + 1
End If
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub
Related
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I'm trying to insert this character "-" at the beginning of each text in column F.
My F column looks like this:
BP850
BP851
BT100
GP160
GP161
I tried this code:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long
Dim str As String
'Change sheet if needed
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
'Loop column F
For i = 1 To LastRow
'Replace the first occurance
str = Replace(.Range("F" & i).Value, "", "-", 1, 1)
.Range("F" & i).Value = str
Next i
End With
End Sub
I expect:
-BP850
-BP851
-BT100
-GP160
-GP161
As an alternative, you could try to utilize .Evaluate. This prevents the need for any loop:
Option Explicit
Sub test()
Dim LastRow As Long
Dim rng As Range
'Change sheet if needed
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
Set rng = .Range("F1:F" & LastRow)
rng.Value = .Evaluate("""'-""&" & rng.Address)
End With
End Sub
Instead of using replace, just concatenate "-" before str
Sub test()
Dim LastRow As Long, i As Long
Dim str As String
'Change sheet if needed
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
'Loop column F
For i = 1 To LastRow
'Replace the first occurance
str = "-" & .Range("F" & i).Value '<== EDIT
.Range("F" & i).Value = str
Next i
End With
End Sub
Your str = Replace(.Range("F" & i).Value, "", "-", 1, 1) has problem. Change it to following:
For i = 1 To LastRow
.Range("F" & i).Value = "-" & .Range("F" & i).Value
Next i
No need to use str variable here.
See if following approach helps.
It will also check
Cell is not blank
Cell doesn't begin with "-"
which should help in case of accidental rerun of the macro!
Option Explicit
Sub test2()
Dim LastRow As Long, i As Long
'Change sheet if needed
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of column F
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
'Loop column F
For i = 1 To LastRow
If Len(.Range("F" & i).Value) > 0 And Left(.Range("F" & i).Value, 1) <> "-" Then _
.Range("F" & i).Value = "-" & .Range("F" & i).Value
Next i
End With
Application.ScreenUpdating = True
End Sub
try this, ie. add "'-" in front of the value. Note the single quote before the -
For i = 1 To lastRow
If .Range("F" & i).Value <> "" Then
If Left(.Range("F" & i).Value, 1) <> "-" Then
.Range("F" & i).Value = "'-" & .Range("F" & i).Value
End If
End If
Next i
Option Explicit
Sub test()
Dim LastRow As Long, i As Long
Dim AdditionString As String, CellString As String, CompleteString As String
AdditionString = "'-"
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
CellString = .Range("A" & i).Value
CompleteString = AdditionString & CellString
.Range("A" & i).Value = CompleteString
Next i
End With
End Sub
I try to copy the headers who have the cell below with "mandatory" value but my Macro stop at the first cell.
Name Phone Houe no Locality
mandatory mandatory
Dim i As Long, j As Long, Lastrow1 As Long, Lastcol1 As Long
Dim mandatory As String
'Lastrow1 = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
Lastcol1 = Sheets("sheet3").Cells(1 & Columns.Count).End(xlToLeft).Column
For i = 1 To Lastcol1
Sheets("sheet4").Activate
Lastcol2 = Sheets("sheet4").Cells(1 & Columns.Count).End(xlToLeft).Column
For j = 1 To Lastcol2
If Sheets("sheet3").Cells(2, i).Value = "mandatory" Then
Sheets("sheet3").Activate
Sheets("sheet3").Cells(i, "A").Copy
Sheets("sheet4").Activate
Sheets("sheet4").Cells(j, "A").Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
Sheets("sheet3").Activate
Sheets("sheet3").Range("A1").Select
End Sub
As in addition to what has been said above in the comments, You are setting j to a column count of 0 by looking in an empty cells for the end.
use this:
Dim i As Long, j As Long, Lastrow1 As Long, Lastcol1 As Long
Lastcol1 = Sheets("sheet3").Cells(1 , Columns.count).End(xlToLeft).Column
For i = 1 To Lastcol1
j = Sheets("sheet4").Cells(1 , Columns.count).End(xlToLeft).Offset(, 1).Column
if j = 2 and Sheets("sheet4").Cells(1,j-1).value ="" then j=1
If ucase(Sheets("sheet3").Cells(2, i).Value) = "MANDATORY" Then
Sheets("sheet3").Cells(1, i).Copy Sheets("sheet4").Cells(1,j)
End If
Application.CutCopyMode = False
Next i
Sheets("sheet3").Range("A1").Select
And by the fact that you are going cell by cell instead of copying you can just make the new cell value equal to the old cell value.
Sheets("sheet4").Cells(1,j).value = Sheets("sheet3").Cells(1, i).value
I'm trying to use the following code to search one cell in each row. If the search value matches a portion of the cell in that row, the entire row is copied and added to the end of another range in another workbook.
Sub GetRowsWithMatchingDates ()
Dim toThisWorkSheet As Worksheet, fromSourceWorkbook As Workbook
Dim NextFreeRow As Long
Dim LastRow As Long
Dim currentRowDate As String
Dim currentRow As Long
Dim TodaysDateAsString As String
Dim currentRowDate As String
TodaysDateAsString = 20150320
Set toThisWorkSheet = ThisWorkbook.Sheets("ImportedData")
NextFreeRow = toThisWorksheet.Range("A" & Rows.Count).End(xlUp).Row + 1
Set fromSourceWorkbook = Workbooks.Open(ThisWorkbook.Path & "JUIDTesting.xlsb")
With fromSourceWorkBook.Sheets("DataToBeSearched")
For i = 1 to To LastRow
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
currentRowDate = Mid(toThisWorkbook.Range("B" & i + 1).Value, 3, 8)
currentRow = .Range("A" & i + 1).Row
If TodaysDateAsString = currentRowDate Then
currentRow.Copy
toThisWorkbook.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
Endif
Next i
End With
fromSourceWorkBook.Close False
End Sub
`
I'm just beginning to use for and with and copy paste code so this could be totally jacked up.
lastrow needs to be before your loop, right now it is undefined and defaults to 0. So you are doing a for i = 1 to 0 esentially.
it should be
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 to To LastRow
currentRowDate = Mid(toThisWorkbook.Range("B" & i + 1).Value, 3, 8)
currentRow = .Range("A" & i + 1).Row
If TodaysDateAsString = currentRowDate Then
currentRow.Copy
toThisWorkbook.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
Endif
Next i
That would correct your first problem.
Your second problem is that toThisWorkbook is not defined anywhere + it is in a with from source workbook, and you do not have a worksheet defined.
Would need to be something like
ThisWorkbook.toThisWorkSheet.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
but also keep in mind that will just keep overwriting the same row because that is what you told it to do. lastrow + 1 = will always be the same constant.
I'm copying an array (Sheet1!A2:A831) and want to paste it on Sheet2! in every 26th row starting at A1.
I was working with this macro, but I'm having some trouble:
Sub test()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("Sheet1!A2:A831").Copy
For i = 26 To LR Step 26
Range("A" & i).PasteSpecial Paste:=xlPasteFormulas
Next i
End Sub
Is this what you are trying?
Sub test()
Dim LR As Long, i As Long, n As Long
With Sheets("Sheet1")
LR = .Range("A" & .Rows.Count).End(xlUp).Row
n = 1
For i = 2 To LR 'A2:A831
.Range("A" & i).Copy
Sheets("Sheet2").Range("A" & n).PasteSpecial _
Paste:=xlPasteFormulas
n = n + 25
Next i
End With
End Sub