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
Related
I created this script that applies conditional formatting to three pivot tables and attempts to save the results of each table into it's own tab in a new workbook.
Here is my code:
Sub conditional_formatting():
' Set dimensions
Dim i As Long
Dim rowCount As Long
Dim numOpen As Range
Dim Ws As Worksheet
Dim xWs1, xWs2, xWs3 As Worksheet
Dim NewBook As Workbook
Dim Nbs1, Nbs2, Nbs3 As Worksheet
Set NewBook = Workbooks.Add
With NewBook
Set Nbs1 = NewBook.Sheets("Sheet1")
NewBook.Sheets.Add.Name = "Sheet2"
Set Nbs2 = NewBook.Sheets("Sheet2")
NewBook.Sheets.Add.Name = "Sheet3"
Set Nbs3 = NewBook.Sheets("Sheet3")
End With
' loop through final report sheets
For Each Ws In ActiveWorkbook.Worksheets
' only loop through lic, loss loc, and reallocate reports
If Ws.Index > 4 And Ws.Index < 8 Then
If Ws.Index = 5 Then
' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row
For i = 14 To rowCount
' Store number of weeks open in working cell
Set numOpen = Range("L" & i)
' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select
Next i
Ws.Range("A13:" & "L" & rowCount).Copy
Nbs1.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs1.Name = "(lic)"
ElseIf Ws.Index = 6 Then
' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row
For i = 11 To rowCount
' Store number of weeks open in working cell
Set numOpen = Range("L" & i)
' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select
Next i
Ws.Range("A10:" & "L" & rowCount).Copy
Nbs2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs2.Name = "(loss loc)"
Else
' get the row number of the last row with data
rowCount = Cells(Rows.Count, "L").End(xlUp).Row
For i = 13 To rowCount
' Store number of weeks open in working cell
Set numOpen = Range("L" & i)
' Apply RAG conditional formatting
Select Case numOpen.Value
Case Is > 4
numOpen.Interior.ColorIndex = 3
Case Is > 2
numOpen.Interior.ColorIndex = 44
Case Else
numOpen.Interior.ColorIndex = 43
End Select
Next i
Ws.Range("A12:" & "L" & rowCount).Copy
Nbs3.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Nbs3.Name = "(reallocate)"
End If
End If
Next Ws
NewBook.SaveAs Filename:="C:\Test1"
MsgBox ("Done")
End Sub
The script does not give me any errors, and it is successfully applying the conditional formatting, in addition to creating the correct tabs with the exception of renaming them as well.
For some reason, it's not actually pasting any values in the new workbook.
Any ideas?
I would try extracting the common code into separate subs.
Some other fixes included, such as qualifying every range with a worksheet object.
Sub conditional_formatting():
' Set dimensions
Dim rowCount As Long
Dim Ws As Worksheet
Dim NewBook As Workbook
Dim Nbs1 As Worksheet, Nbs2 As Worksheet, Nbs3 As Worksheet
Dim wbSrc As Workbook
Set wbSrc = ActiveWorkbook '<<<<remember this workbook
Set NewBook = Workbooks.Add
With NewBook
Set Nbs1 = .Sheets("Sheet1")
.Sheets.Add.Name = "Sheet2" '<< use your With here...
Set Nbs2 = .Sheets("Sheet2")
.Sheets.Add.Name = "Sheet3"
Set Nbs3 = .Sheets("Sheet3")
End With
' loop through final report sheets
For Each Ws In wbSrc.Worksheets
rowCount = Ws.Cells(Ws.Rows.Count, "L").End(xlUp).Row 'only need this once
If Ws.Index = 5 Then
FormatRange Ws.Range("L14:L" & rowCount)
CopyValues Ws.Range("A13:L" & rowCount), Nbs1.Range("A1")
Nbs1.Name = "(lic)"
ElseIf Ws.Index = 6 Then
FormatRange Ws.Range("L11:L" & rowCount)
CopyValues Ws.Range("A10:L" & rowCount), Nbs2.Range("A1")
Nbs2.Name = "(loss loc)"
ElseIf Ws.Index = 7 Then
FormatRange Ws.Range("L13:L" & rowCount)
CopyValues Ws.Range("A12:L" & rowCount), Nbs3.Range("A1")
Nbs3.Name = "(reallocate)"
End If
Next Ws
NewBook.SaveAs Filename:="C:\Test1"
MsgBox ("Done")
End Sub
'copy values from rngFrom into rngTo (resizing as necessary)
Sub CopyValues(rngFrom As Range, rngTo As Range)
With rngFrom
rngTo.Cells(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End Sub
'loop over and format a range according to cell values
Sub FormatRange(rng As Range)
Dim c As Range
For Each c In rng.Cells
Select Case c.Value
Case Is > 4
c.Interior.ColorIndex = 3
Case Is > 2
c.Interior.ColorIndex = 44
Case Else
c.Interior.ColorIndex = 43
End Select
Next c
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
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
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