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
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 few non-contiguous ranges that may vary in size each time it is run. I would like to take each of the ranges and copy and paste them onto their own individual worksheets (one range per sheet).
My code currently works for the first range and sheet. After the second sheet is created, the ranges are highlighted, but the first range is again copied and pasted onto the second sheet, instead of the corresponding second range. Then, the third sheet is created, but again, only the first range is copied and pasted onto this sheet. I know something is wrong with my looping, but I can't figure out where.
I have exhausted all of my resources. I just can't figure out why the loop isn't getting to the other 2 ranges.
'Get current sheet name
Dim activeSheetName As String
activeSheetName = ActiveSheet.Name
'Create a new sheet to reformat existing data
Dim newSheetName As String
newSheetName = (activeSheetName + "_Data")
Dim filterRange As range
Dim areasCount As Integer
For Each a In filterRange.Areas
Sheets(newSheetName).Select
filterRange.Select
range(Selection, Selection.End(xlToRight)).Select
areasCount = Selection.Areas.Count
With a
For i = 2 To areasCount + 1
Selection.Copy
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
Selection.PasteSpecial paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=False
Application.CutCopyMode = False
End With
Next i
End With
Next a
I have tried to incorporate the following code I found in a book, but no such luck.
Dim SelAreas() As range
Dim pasteRange As range
Dim upperLeft As range
Dim numAreas As Long, i As Long
Dim topRow As Long, leftCol As Long
Dim rowOffset As Long, colOffset As Long
If TypeName(Selection) <> "Range" Then Exit Function
numAreas = Selection.Areas.Count
ReDim SelAreas(1 To numAreas)
For i = 1 To numAreas
Set SelAreas(i) = Selection.Areas(i)
Next
topRow = ActiveSheet.Rows.Count
leftCol = ActiveSheet.Columns.Count
For i = 1 To numAreas
If SelAreas(i).Row < topRow Then topRow = SelAreas(i).Row
If SelAreas(i).Column < leftCol Then leftCol = SelAreas(i).Column
Next
Set upperLeft = Cells(topRow, leftCol)
On Error Resume Next
Set pasteRange = range("A50")
On Error GoTo 0
If TypeName(pasteRange) <> "Range" Then Exit Function
Set pasteRange = pasteRange.range("A1")
For i = 1 To numAreas
rowOffset = SelAreas(i).Row - topRow
colOffset = SelAreas(i).Column - leftCol
SelAreas(i).Copy
range("A1").Value = pasteRange.Offset(rowOffset, colOffset)
Next i
For Each a In filterRange.Areas
Sheets(newSheetName).Select
range(a, a.End(xlToRight)).Copy
With a
If filterRange Is Nothing Then
MsgBox ("Value not present in this workbook.")
Else
With Sheets.Add(After:=Sheets(Sheets.Count))
.Name = a.Cells(1, 1).Value
.range("A1").Value = a.Offset(, 1)
range("A50").Select
ActiveSheet.paste
End With
range("A10:A49").Select
range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
range("A1").Select
End If
End With
Next a
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
My code filters one column then prints.
I need to filter based on two columns and then print. I.e. filter based on engineer name (column 1) and route (column 2). Right now, it filters on engineer name (column 1).
Option Explicit
Sub filterandprint()
Dim TempWks As Worksheet
Dim wks As Worksheet
Dim myRng As Range
Dim myCell As Range
'change to match your worksheet name
Set wks = Worksheets("Table")
Set TempWks = Worksheets.Add 'creates temporary worksheet
wks.AutoFilterMode = False 'remove the arrows
'assumes headers only in row 1, columns(1) will be the number of the column you base your filtering
'this copies the unique filtering and pastes it on a new temp worksheet
wks.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), Unique:=True
With TempWks
Set myRng = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
'looping
With wks
For Each myCell In myRng.Cells
.UsedRange.AutoFilter Field:=1, Criteria1:=myCell.Value
'.UsedRange.AutoFilter Field:=2, Criteria1:=myCell.Value
.PrintOut Preview:=True
Next myCell
End With
Application.DisplayAlerts = False
TempWks.Delete 'deletes temporary worksheet
Application.DisplayAlerts = True
End Sub
For anyone else searching for an answer, edited the above looping section to the below and it worked:
...
Dim iLoop As Integer
'looping
With wks
For iLoop = 2 To 65
.UsedRange.AutoFilter Field:=1, Criteria1:=TempWks.Cells(iLoop, 1).Value
.UsedRange.AutoFilter Field:=2, Criteria1:=TempWks.Cells(iLoop, 2).Value
.PrintOut Preview:=True
Next iLoop
End With
Application.DisplayAlerts = False
TempWks.Delete 'deletes temporary worksheet
Application.DisplayAlerts = True
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)