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
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 have a spreadsheet with 1000+ rows. Trying to copy the data matching in one of the columns "H" to sheet which is also given the name from H. But would like to also sort data such that values in column "H" that match"comp-harb"; "comp-harb-active"; comp-harb-exp" all get copied to a single worksheet labelled speficically as "comp-harb". I was able to lookup answers to find a code which I was able to use. But it separates the "comp*" into separate worksheets. Is there a way to specify to copy them into one worksheet? Any help is greatly appreciated.
Option Explicit
Sub CopyRows()
Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String
Dim Cell As Range
Dim bk As Workbook
Set bk = Application.ActiveWorkbook
Application.ScreenUpdating = False
With Sheets("combined")
Set rngMyRange = .Range(.Range("H2"), .Range("H65536").End(xlUp))
For Each rngCell In rngMyRange
rngCell.EntireRow.Select
Selection.Copy
If rngCell Like "comp-harb*" Then GoTo Line1 Else GoTo Line2
Line1:
If WorksheetExists("comp-harb") Then
SheetName = "comp-harb"
Sheets(SheetName).Select
Set sht = ActiveWorkbook.Worksheets(SheetName)
LastRow = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
Rows(LastRow + 1).Select
Selection.Insert Shift:=xlDown
Else: Sheets.Add After:=ActiveSheet
Rows("1:1").Select
Selection.Insert Shift:=xlDown
ActiveSheet.Name = "comp-harb"
GoTo Lastline
End If
Line2:
If WorksheetExists(rngCell.Value) Then
SheetName = rngCell.Value
Sheets(SheetName).Select
Set sht = ActiveWorkbook.Worksheets(SheetName)
LastRow = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
Rows(LastRow + 1).Select
Selection.Insert Shift:=xlDown
Else: Sheets.Add After:=ActiveSheet
Rows("1:1").Select
Selection.Insert Shift:=xlDown
ActiveSheet.Name = rngCell.Value
End If
GoTo Lastline
'Go back to the DATA sheet
Lastline:
Sheets("combined").Select
Next
End With
End Sub
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!H1)")
End Function
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
I have the following which works ok but instead of copying the entire row from the "Combined" worksheet to the "Summary" worksheet I only want to copy columns A to T. This is a first attempt so any help would be gratefully received!
`Private Sub CommandButton1_Click()
'Define Variables
Dim DestSh As Worksheet
Dim s As Worksheet
Dim c As Integer
Dim i
Dim LastRow
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the Combined sheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Combined").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a new Combined worksheet
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Combined"
'Select Summary worksheet and copy headings and column widths to Combined worksheet
Sheets("Summary").Activate
Range("A24").EntireRow.Select
Selection.Copy Destination:=Sheets("Combined").Range("A1")
For c = 1 To Sheets("Summary").Columns.Count
Sheets("Combined").Columns(c).ColumnWidth = Sheets("Summary").Columns(c).ColumnWidth
Next
'Loop through all worksheets sheets that begin with ra
'and copy to the combined worksheet
For Each s In ActiveWorkbook.Sheets
If LCase(Left(s.Name, 2)) = "ra" Then
Application.Goto Sheets(s.Name).[A1]
Selection.Range("A23:Q50").Select
Selection.Copy Destination:=Sheets("Combined"). _
Cells(Rows.Count, 1).End(xlUp)(2)
End If
Next
'Copy all rows that contain Yes in column A to Summary worksheet
LastRow = Sheets("Combined").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Summary").Range("A25:V500").ClearContents
For i = 1 To LastRow
If Sheets("Combined").Cells(i, "A").Value = "Yes" Then
Sheets("Combined").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
'Force return to Summary worksheet
Worksheets("Summary").Activate
End Sub
You can use the .Resize() method to change the range that is copied. Replace your line where you copy and paste it to the new destination with this one and it should work:
Sheets("Combined").Cells(i, "A").Resize(1, 20).Copy Destination:=Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Offset(1)
I have a workbook with multiple sheets and a master sheet. I would like to search through all of the sheets and select rows with dates in column A that are 120 days old or older and then copy those rows to the master sheet starting on row 11. I have looked at this code:
'---------------------------------------------------------------------------------------
' Module : Module1
' DateTime : 09/05/2007 08:43
' Author : Roy Cox (royUK)
' Website :for more examples and Excel Consulting
' Purpose : combine data from multiple sheets to one
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
' projects but please leave this header intact.
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : Combinedata
' Author : Roy Cox
' Website : www.excel-it.com
' Date : 10/10/2010
' Purpose : Combine data from all sheets to a master sheet
'---------------------------------------------------------------------------------------
'
Sub Combinedata()
Dim ws As Worksheet
Dim wsmain As Worksheet
Dim DataRng As Range
Dim Rw As Long
Dim Cnt As Integer
Const ShtName As String = "Master" '<-destination sheet here
Cnt = 1
Set wsmain = Worksheets(ShtName)
wsmain.Cells.Clear
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsmain.Name Then
If Cnt = 1 Then
Set DataRng = ws.Cells(2, 1).CurrentRegion
DataRng.copy wsmain.Cells(1, 1)
Else: Rw = wsmain.Cells(Rows.Count, 1).End(xlUp).Row + 1
MsgBox ws.Name & Rw
Set DataRng = ws.Cells(2, 1).CurrentRegion
'don't copy header rows
DataRng.Offset(1, 0).Resize(DataRng.Rows.Count - 1, _
DataRng.Columns.Count).copy ActiveSheet.Cells(Rw, 1)
End If
End If
Cnt = Cnt + 1
Next ws
End Sub
But this transfers all sheets to the master...
Option Explicit
Sub CopyRowByRow()
Dim master As Worksheet, sheet As Worksheet
Set master = Sheets("Sheet1")
Dim i As Long, nextRow As Long
master.Cells.ClearContents
For Each sheet In ThisWorkbook.Sheets
If sheet.Name <> master.Name Then
For i = 1 To sheet.Range("A" & Rows.Count).End(xlUp).Row
If Not IsEmpty(sheet.Range("A" & i)) Then
If DateDiff("d", Now(), sheet.Range("A" & i).Value) < -120 Then
nextRow = master.Range("A" & Rows.Count).End(xlUp).Row + 1
If nextRow = 2 And IsEmpty(master.Range("A" & nextRow).Offset(-1, 0)) Then
nextRow = 11
End If
sheet.Rows(i & ":" & i).Copy
master.Rows(nextRow & ":" & nextRow).PasteSpecial _
Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
End If
Next i
End If
Next
End Sub