I'm new on VBA and also on this site. I found and adapted this code to my needs, but it copy only the first row from column A(sheet "Vectori") in the blank cells of "TABEL" sheet(column A), and i want to copy all values from column A(sheet "Vectori"), not only one.
Sub test()
Dim myvalue As String
Dim lastrow As Long
lastrow = Rows(Rows.count).End(xlUp).Row
Worksheets("Vectori").Select
myvalue = Range("A2").value
Worksheets("TABEL").Select
Range("A2").Select
'go to first blank cell
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
'write variable values into this blank row
ActiveCell.value = myvalue
Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).copy
ActiveCell.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End Sub
Just increase the Range to suit your needs.
Replace:
Range("A2")
With:
Range("A2:Z100")
Just select the range that covers your entire data.
I solved it :)
Sub test()
Dim thisarray As Variant
Dim lastrow As Long
Dim index As Integer
index = 1
lastrow = Cells(Rows.count, 1).End(xlUp).Row
thisarray = Worksheets("Vectori").Range("A2:A" & lastrow).value
While index <= UBound(thisarray)
Worksheets("TABEL").Select
Range("A2").Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.value = thisarray(index, 1)
index = index + 1
Wend
End Sub
Have a nice day!
Related
How can i create code which will repeating code until columna a value will be empty
this is my code.
Sheets("sheet4").Select
Sheets("sheet4").Range("$A$1:$AG$2336").AutoFilter Field:=1, Criteria1:= _
Sheets("sheet1").Range("a3")
Sheets("sheet4").Range("a1:ad1").find(Sheets("sheet1").Range("L3").Value).offset(2, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.offset(2, 0).Select
Loop
Selection.Copy Sheets("sheet1").Range("b3")
Sheets("sheet1").Select
End Sub
I need to copy my selection down until column a will end ( i mean cell in column a will be empty). Can u please help me ??
Replace the 3 with a variable and put the code in a loop.
Option Explicit
Sub macro()
Dim wb As Workbook
Dim ws1 As Worksheet, ws4 As Worksheet
Dim colA, colL, iRow As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws4 = wb.Sheets("Sheet4")
ws4.Select
iRow = 3
colA = ws1.Cells(iRow, "A")
Do While Len(colA) > 0
colL = ws1.Cells(iRow, "L")
If Len(colL) > 0 Then
' apply filter
ws4.Range("A1:AG2336").AutoFilter Field:=1, Criteria1:=colA
' copy filtered data
ws4.Range("A1:AD1").Find(colL).Offset(2, 0).Select
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(2, 0).Select
Loop
Selection.Copy ws1.Range("B" & iRow)
'
End If
' next value in col A
iRow = iRow + 1
colA = ws1.Cells(iRow, "A")
Loop
MsgBox iRow - 3 & " rows scanned on " & ws1.Name, vbInformation
End Sub
i'm trying to make some changes in excel file using VBA, the file contains many sheets
the code should make changes for 1st sheet then go to the next and next,
but after makes the changes in 1st sheet and go to 2nd it shows:
Error no 1004 "Object error".
Here the code:
Sub AddRefNo()
'This code adds Reference Number to All BOQ sheets based on Worksheet Name
'select the first sheet
Worksheets(4).Select
' Work in One Sheet
Do While ActiveSheet.Index < Worksheets.Count
'add new Column
'the error happens here
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Ref. No"
Range("A2").Select
'Find Sheet Name
MySheet = ActiveSheet.Name
'creat numbering system
Dim Noe As String
Noe = 0
' Find the last row
Dim LastRow As Integer
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("E2").Select
'repeat steps to the last row
Do While ActiveCell.Row < LastRow
'checking if the cell is not blank
Do While ActiveCell.Value <> ""
ActiveCell.Offset(0, -4).Select
Noe = Noe + 1
ActiveCell.Value = MySheet & " - " & Noe
ActiveCell.Offset(0, 4).Select
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
Loop
Noe = 0
Range("A1").Select
ActiveSheet.Next.Select
Loop
Worksheets(1).Select
End Sub
Here is a way to reliable loop through your worksheet index numbers:
Sub AddRefNo()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim x As Long
For x = 4 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(x)
'Your code to work with ws as a parent
Next x
End Sub
This should do the trick if you want to loop from sheet 4:
Option Explicit
Sub AddRefNo()
'Declare a worksheet variable
Dim ws As Worksheet
'Loop every sheet in the workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Index < 4 Or ws.Index = ThisWorkbook.Worksheets.Count Then GoTo nextWorksheet
'Reference always the sheet
With ws
'Calculate last row
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
'Insert a column
.Range("A:A").Insert
.Range("A1") = "Ref. No"
'Put the name sheet + reference starting from 1
With .Range("A2:A" & LastRow)
.FormulaR1C1 = "=" & Chr(34) & ws.Name & Chr(34) & "&ROW(RC)-1"
.Value = .Value
End With
End With
nextWorksheet:
Next ws
End Sub
I have recorded a Macro in Excel 2016, however whenever I run this Macro it overwrite my previous answer, how should I put my new answer to next row?
Sub update()
'
' update Macro
'
'
Range("B4:G4").Select
Selection.Copy
Sheets("Sheet4").Select
Range("B2").Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Range("B7:G7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Range("B3").Select
ActiveSheet.Paste
End Sub
Just add lastRow1 line to set always lastRow +1 (empty cell)
Sub updateM()
Dim lastRow1 As Long
lastRow1 = Sheets("Sheet4").Cells(Rows.Count, 2).End(xlUp).row + 1
Range("B4:G4").Copy Sheets("Sheet4").Range("B2")
Sheets("Sheet3").Range("B7:G7").Copy Sheets("Sheet4").Range("B3").Select
End Sub
This should do it. You should try to a void Select or Activate as Pᴇʜ said, here is an example on how to do it:
Option Explicit
Sub update()
'
' update Macro
'
'
Dim Answer1 As Range, Answer2 As Range
With ThisWorkbook.Sheets("sheet3")
Set Answer1 = .Range("B4:G4") 'set the range for the first answer
Set Answer2 = .Range("B7:G7") 'set the range for the second answer
End With
Dim LastRow As Long
With ThisWorkbook.Sheets("Sheet4")
'Copy the first answer
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'calculate next blank cell
Answer1.Copy .Cells(LastRow, 2)
'Copy the second answer
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1 'calculate next blank cell
Answer2.Copy .Cells(LastRow, 2)
End With
End Sub
I am still new to coding so i apologise if i dont understand everything.
I need to check each cell of D3:D5000 if they start with GUF. Then remove the GUF from it. Else dont do anything.
This is what ive been trying to use but im getting an error Do ohne Loop:
Sub RemoveGUFfromcellsstartingwithGUF()
Range("D3").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell = "end"
Range("B1").Select
Do Until ActiveCell = "end"
If ActiveCell = "GUF*" Then
ActiveCell.Value = Mid(Cell, 4, 999999)
End If
ActiveCell.Offset(1, 0).Select
End Sub
Thanks for any help/suggestions
Firstly, when you are looping through cells, it's best to use For each cell in cells, no need to change selection then.
Firstly, set a range in which you want it to run.
Sub RemoveGUFfromcellsstartingwithGUF()
dim first_cell as Range
dim last_cell as Range
dim rng as Range
set first_cell = ActiveSheet.Range("D1") 'first cell of your range
set last_cell = ActiveSheet.Range("D5000") 'last cell of your range
set rng = Range(first_cell, last_cell) 'range from first_cell to last_cell
For Each cell in rng.cells 'looping through cells of the range
'What you do here will be done to every cell.
if left(cell.value, 3) = "GUF" then cell.value = Mid(cell.value,4)
Next cell
End Sub
I hope this helps.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Find last row in Col D
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Loop through cell in Col D
For i = 3 To lRow
If .Range("D" & i).Value Like "GUF*" Then
.Range("D" & i).Value = Mid(.Range("D" & i).Value, 4)
End If
Next i
End With
End Sub
My process consists:
Going through the cell values in Column A of sheet 1
Checking to see if the cell values from sheet 1 match with any of the values in Column C of sheet 2
If there is a match, copy the entire row in which there is a match from Sheet 2 to Sheet 3.
I posted my code below but somehow can't get it to work.
Sub Test1()
Dim Name As String
Dim lastrow As Long
Dim Cell As Variant
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Name = Cells(i, 1)
If Name <> "" Then
For Each Cell In Sheets("Sheet2").Range("C2:C4000")
If Cell.Value = Name Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Sheet3").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End If
Next
End Sub
No need to loop through every cell in Sheet2!C:C.
Sub Test1()
Dim i As Long, c as variant
With Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
c = Application.Match(.Cells(i, "A").Value2, Worksheets("Sheet2").Columns(3), 0)
If Not IsError(c) Then
Worksheets("Sheet2").Rows(c).Copy _
Destination:=Worksheets("Sheet3").Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next i
End With
End Sub
You need to get the .Value of the cell.
Name = CStr(Cell(i, 1).Value)
Also, there is a built in function to determine if a cell is empty.
If Not IsEmpty(Cell(i, 1).Value) Then
Also, I would suggest setting a reference to the worksheet instead of just saying Cells()
Dim ws As Worksheet
Set ws = Excel.Application.ThisWorkbook.Worksheets("wb name here")
ws.Cells(i, 1).Value
Hope this helps!
Where your errors were coming from was it was getting confused what sheet was selected. So you needed to be more explicit, as below.
Sub Test1()
Dim Name As String
Dim lastrow As Long
Dim Cell As Variant
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Name = Sheets("Sheet1").Cells(i, 1)
If Name <> "" Then
For Each Cell In Sheets("Sheet2").Range("C2:C4000")
If Cell.Value = Name Then
matchRow = Cell.Row
Sheets("Sheet2").Select
ActiveSheet.Rows(matchRow).Select
Selection.Copy
Sheets("Sheet3").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End If
Next
End Sub