Related
I had the simple problem that Excel always jumped to the top after a macro ran automatically. Whenever I did a change in any cell the macro runs. However, after finishing, Excel jumps to the top. I want to stay where I edited the cell. I know there are multiple ways to fix this. My solution was one of the following.
Here my code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Selec, LastRow, LastCol, r As Integer
Dim rng As Range
Set Selec = Range(Target.Address)
LastCol = Range("XFD1").End(xlToLeft).Column
If Selec.Row > Range("A" & Rows.Count).End(xlUp).Row Then
LastRow = Selec.Row
Cells(Selec.Row, 1).value = Application.WorksheetFunction.Max(Range(Cells(1, 1), Cells(Selec.Row - 1, 1))) + 1
With Cells(Selec.Row, 4).Validation
.Delete
.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=Parameters!$A$1:$A$3"
End With
Cells(Selec.Row, 4).value = "Not Started"
Else: LastRow = Range("A" & Rows.Count).End(xlUp).Row
End If
Set rng = Range(Cells(1, 1), Cells(LastRow, LastCol))
If Not Application.Intersect(rng, Selec) Is Nothing Then
For r = 2 To LastRow
Select Case Cells(r, 4)
Case "Completed"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(146, 208, 80)
Case "Not Started"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(255, 255, 255)
Case "In Progress"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(255, 255, 0)
End Select
If IsEmpty(Range(Cells(r, 1), Cells(r, LastCol))) = False Then
With Range("A" & r & "," & "C" & r & "," & "D" & r)
.HorizontalAlignment = xlCenter
End With
With Range("B" & r & "," & "E" & r & "," & "F" & r)
.WrapText = True
.HorizontalAlignment = xlLeft
End With
End If
Next r
End If
'Show Only In Progress and Not Started
Worksheets("Task List").Range("A1").AutoFilter Field:=4, Criteria1:=Array("In Progress", "=", "Not Started"), Operator:=xlFilterValues
'Worksheets("Task List").AutoFilter.Sort.SortFields.Add Key:=Range("C1" & Range("C" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending
Worksheets("Task List").AutoFilter.Sort.SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending
With Worksheets("Task List").AutoFilter.Sort
.Header = xlYes
.Apply
End With
//Without one of the following lines Excel jumps to the top, but I want to stay at the end/selected cell. Uncommenting one of the following three lines solves this problem.
'Range(Target.Address).Select
'Selection.Select
'Selection.Activate
End Sub
It seems like that the jumping up is a side effect of filtering or sorting. To prevent Excel to jump up just add the following code at the end:
Target.Select
The following two lines of code work too, but are not recommended:
Selection.Select
or
Selection.Activate
All of them should prevent Excel to jump to the top and go back to current selection.
Try this good sir! This makes a temporary view (called "TempView") at the beginning of the code, then shows that view at the end and then immediately deletes this same view.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Selec, LastRow, LastCol, r As Integer
Dim rng As Range
ActiveWorkbook.CustomViews.Add ViewName:="TempView", PrintSettings:=True, _
RowColSettings:=True
Set Selec = Range(Target.Address)
LastCol = Range("XFD1").End(xlToLeft).Column
If Selec.Row > Range("A" & Rows.Count).End(xlUp).Row Then
LastRow = Selec.Row
Cells(Selec.Row, 1).Value = Application.WorksheetFunction.Max(Range(Cells(1, 1), Cells(Selec.Row - 1, 1))) + 1
With Cells(Selec.Row, 4).Validation
.Delete
.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=Parameters!$A$1:$A$3"
End With
Cells(Selec.Row, 4).Value = "Not Started"
Else: LastRow = Range("A" & Rows.Count).End(xlUp).Row
End If
Set rng = Range(Cells(1, 1), Cells(LastRow, LastCol))
If Not Application.Intersect(rng, Selec) Is Nothing Then
For r = 2 To LastRow
Select Case Cells(r, 4)
Case "Completed"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(146, 208, 80)
Case "Not Started"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(255, 255, 255)
Case "In Progress"
Range(Cells(r, 1), Cells(r, LastCol)).Interior.Color = RGB(255, 255, 0)
End Select
If IsEmpty(Range(Cells(r, 1), Cells(r, LastCol))) = False Then
With Range("A" & r & "," & "C" & r & "," & "D" & r)
.HorizontalAlignment = xlCenter
End With
With Range("B" & r & "," & "E" & r & "," & "F" & r)
.WrapText = True
.HorizontalAlignment = xlLeft
End With
End If
Next r
End If
'Show Only In Progress and Not Started
Worksheets("Task List").Range("A1").AutoFilter Field:=4, Criteria1:=Array("In Progress", "=", "Not Started"), Operator:=xlFilterValues
'Worksheets("Task List").AutoFilter.Sort.SortFields.Add Key:=Range("C1" & Range("C" & Rows.Count).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending
Worksheets("Task List").AutoFilter.Sort.SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending
With Worksheets("Task List").AutoFilter.Sort
.Header = xlYes
.Apply
End With
ActiveWorkbook.CustomViews("TempView").Show
ActiveWorkbook.CustomViews("TempView").Delete
End Sub
I have written some Excel VBA to add weekday dates, down column "A", for 41 worksheets. The dates build to 90 days out and then have a "Beyond mm/dd/yy" text value in the following cell. The code is run every weekday, with the exception of holidays, and builds the dates over the cell that was previously the text cell. This process works beautifully, except for the first of 41 worksheets, where the added date(s) display as text, even though their "format" will say they are a date. The other 40 display as dates. I have attempted to wrap my calculated dates in CDate() and DateValue(), and both. The closes I came was copying down the above cell, but then I will get non-weekdays, as Excel builds the next autofill. I even tried to revisit the one worksheet with the issue and roll through the IF Then Else again, but, with a defined value for the "Beyond" text row and then reassign the dates - this yielded the same result; so, I have concluded that the issue is likely related to how I have written the IF Then Else portion.
Thank you for any ideas~
Dim count As Integer
Sheets("ABCD").Activate
For count = 1 To 41
'*************************************************************************** ********************
'Inserts Dates for weekdays, until 90 days out, then a "Beyond MM/DD/YY" value for the last date
'***********************************************************************************************
Dim ThisSheet As String
'turn off auto formula calculation
Application.Calculation = xlManual
Range("A1").Activate
'find the current "Beyond" date cell
Columns("A:A").Select
Selection.Find(What:="Beyond", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("A" & ActiveCell.Row).Select
'Add business days to column(A:A) until the next business day would be 91 days or greater
Do Until ((Weekday(Range("A" & ActiveCell.Row - 1)) = 6) And _
(DateAdd("w", 3, Range("A" & ActiveCell.Row - 1))) >= (DateAdd("d", 91, Date))) Or _
((Weekday(Range("A" & ActiveCell.Row - 1)) <> 6) And _
(DateAdd("d", 1, Range("A" & ActiveCell.Row - 1))) >= (DateAdd("d", 91, Date)))
If Weekday(Range("A" & ActiveCell.Row - 1)) = 6 Then
ActiveCell.NumberFormat = "m/d/yyyy"
ActiveCell.Value = DateValue(DateAdd("w", 3, Range("A" & (ActiveCell.Row - 1))))
Selection.NumberFormat = "m/d/yyyy"
ElseIf Weekday(Range("A" & ActiveCell.Row - 1)) = 7 Then
ActiveCell.NumberFormat = "m/d/yyyy"
ActiveCell.Value = DateValue(DateAdd("w", 2, Range("A" & (ActiveCell.Row - 1))))
ActiveCell.Select
Selection.NumberFormat = "m/d/yyyy"
Else: ActiveCell.NumberFormat = "m/d/yyyy"
ActiveCell.Value = DateValue(DateAdd("w", 1, Range("A" & (ActiveCell.Row - 1))))
ActiveCell.Select
Selection.NumberFormat = "m/d/yyyy"
End If
Selection.Offset(1, 0).Activate
Loop
'Add in the "Beyond" date, to column(A:A)
ActiveCell.Value = "Beyond " & Format((DateAdd("d", 90, Date)), "mm/dd/yy")
Range("A1").Select
'*****************************************************************************************
'****************************************************************
'Copies down formulas to the last date or "Beyond MM/DD/YYYY" row
'****************************************************************
'Set LastRow Value for end of desired formula range
LTCashSheet_LastRow = Range("A" & Rows.count).End(xlUp).Row
'Set LastRow Value for beginning formulas to copy down
LTCashSheet_BegCopyRange = Range("B" & Rows.count).End(xlUp).Row
Range("B" & LTCashSheet_BegCopyRange & ":N" & LTCashSheet_BegCopyRange).Select
Selection.AutoFill Destination:=Range("B" & LTCashSheet_BegCopyRange & ":N" & LTCashSheet_LastRow), Type:=xlFillDefault
Range("B" & LTCashSheet_BegCopyRange & ":N" & LTCashSheet_LastRow).Select
Columns("A:A").AutoFit
'****************************************************************
'****************************************************************
'Hide Rows 11 through rows prior to today's date row*************
'****************************************************************
Set TheRng = Range("A1", Range("A" & Rows.count).End(xlUp))
CurrDtRow = TheRng.Find(What:=Date, LookAt:=xlWhole).Row
Rows("11:" & (CurrDtRow - 2)).Select
Selection.EntireRow.Hidden = True
Range("A1").Select
'****************************************************************
'Go to next sheet and repeat, through 'count'********************
ActiveSheet.Next.Select
Next count
I found helpful information from Excel VBA date formats. I did not integrate the solution to prevent the above from happening, within my IF THEN ELSE; however, I was able to add some clean up using the function and applying the code to the cells immediately above the "Beyond" value, which were the cells that were a strange hybrid of a String and a Date. I am good to go, but, feel free to comment if you think I should have gone a different route.
Thank you!
Function CellContentCanBeInterpretedAsADate(cell As Range) As Boolean
Dim d As Date
On Error Resume Next
d = CDate(cell.Value)
If Err.Number <> 0 Then
CellContentCanBeInterpretedAsADate = False
Else
CellContentCanBeInterpretedAsADate = True
End If
On Error GoTo 0
End Function
Sub FixDtFrmtWithFnctn()
Dim cell As Range
Dim cvalue As Double
Sheets("NCE1").Select
Set TheRng4 = Range("A1", Range("A" & Rows.count).End(xlUp))
DtFrmtFixRow = TheRng4.Find(What:=("Beyond"), LookAt:=xlPart).Row
Set cell = Range("A" & (DtFrmtFixRow - 1))
If CellContentCanBeInterpretedAsADate(cell) Then
cvalue = CDate(cell.Value)
cell.Value = cvalue
cell.NumberFormat = "m/d/yyyy"
Else
cell.NumberFormat = "General"
End If
Set cell = Range("A" & (DtFrmtFixRow - 2))
If CellContentCanBeInterpretedAsADate(cell) Then
cvalue = CDate(cell.Value)
cell.Value = cvalue
cell.NumberFormat = "m/d/yyyy"
Else
cell.NumberFormat = "General"
End If
Set cell = Range("A" & (DtFrmtFixRow - 3))
If CellContentCanBeInterpretedAsADate(cell) Then
cvalue = CDate(cell.Value)
cell.Value = cvalue
cell.NumberFormat = "m/d/yyyy"
Else
cell.NumberFormat = "General"
End If
End Sub
I have the following code, which is a work in progress, but VBA keeps saying the If Range("G"&CRow).text = "True" then is true in the highlighted row, when it obviously isn't. Can anyone help me figure this out?
Range("G1").FormulaR1C1 = _
"=IF(OR(ISNUMBER(SEARCH(""GS "",RC[-6])),ISNUMBER(SEARCH(""#"",RC[-6]))),""TRUE"",""FALSE"")"
Range("G1").AutoFill Destination:=Range("G1:G" & lastrow)
With Range("G1:G" & lastrow)
.Value = .Value
End With
Dim T As Integer
Dim CRow As Integer
CRow = 1
For Each cell In Range("G1:G" & lastrow)
If Range("G" & CRow).Text = "TRUE" Then
cell.Select
ActiveCell.Offset(0, -5).Select
If Selection.Value = "" Then
Selection.Resize(, 4).Select
Selection.Delete Shift:=xlUp
ActiveCell.Offset(2, 0).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
CRow = CRow - 1
End If
Else
CRow = CRow + 1
End If
Next
BECAUSE of this
CRow = 1
For Each cell In Range("G1:G" & lastrow)
If Range("G" & CRow).Text = "TRUE" Then
You are assiging 1 to CRow and using that in each iteration. So actually you are always testing Just Row 1.
Change Range("G" & CRow).Text to cell.Text
See below example to delete the same group of cells using a reverse loop and not selecting. I believe I interpreted, and thus changed, this line properly ActiveCell.Offset(2, 0).Select, but let me know if I'm mistaken and it doesn't function as expected.
Range("G1").FormulaR1C1 = _
"=IF(OR(ISNUMBER(SEARCH(""GS "",RC[-6])),ISNUMBER(SEARCH(""#"",RC[-6]))),""TRUE"",""FALSE"")"
Range("G1").AutoFill Destination:=Range("G1:G" & lastrow)
With Range("G1:G" & lastrow)
.Value = .Value
End With
Dim T As Integer
For T = 1 to lastrow Step -1
Set cell = Range("G" & T)
If cell.Text = "TRUE" Then
If cell.offset(0,-5) = "" Then
cell.Offset(0,-5).Resize(,4).Delete Shift=xlUp
Range("G" & T + 2).Insert Shift:=xlDown CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
Next
I've been at this one a while and I have had it working quickly, executing in a couple of seconds over a couple of thousand lines of data, but for some reason it's now constantly locking up at the point of applying the formula to the range.
I've tried it with Index/Match and with Vlookup and both hang at the same point. I then re-worked the whole thing to read all of the data into a couple of arrays, do the lookup entirely in VBA with Application.Worksheetfunction and return the values to a third array before dumping back into Excel, but I abandoned this as the loop was really messy.
Code is as follows, noted at the point it locks - always at the line .Formula = "***Etc. Apologies if it looks a little messy, it's a work in progress with code still to be tidied up.
Any ideas?
Sub ppmTracking()
On Error GoTo EndHere
Dim trPath
trPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\[MichPPMTracking3.xls]MichPPMTracking3"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets(1).Activate
'''''ORDER STATUS
With Range("R2", Range("B2").End(xlDown).Offset(0, 16))
.Formula = "=INDEX('" & trPath & "'!F:F, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
'''''LINE STATUS
With Range("S2", Range("B2").End(xlDown).Offset(0, 17))
.Formula = "=INDEX('" & trPath & "'!G:G, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
''''DESPATCH QUANTITY
With Range("T2", Range("B2").End(xlDown).Offset(0, 18))
.Formula = "=INDEX('" & trPath & "'!H:H, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
.Copy
.PasteSpecial Paste:=xlPasteValues
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Interior.ColorIndex = xlNone
End With
i = 2
For Each cell In Range("T2", Range("B2").End(xlDown).Offset(0, 18))
If Not cell.Text = "#N/A" Then
If Not cell.Text = "" Then
If cell.Value < Range("F" & i).Value Then cell.Interior.ColorIndex = 6
End If
End If
i = i + 1
Next cell
'''''DESPATCH DATE
With Range("U2", Range("B2").End(xlDown).Offset(0, 19))
.Formula = "=INDEX('" & trPath & "'!I:I, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))" '<<<<LOCKS UP HERE
.Copy
.PasteSpecial Paste:=xlPasteValues
.NumberFormat = "General"
End With
For Each cell In Range("U2", Range("B2").End(xlDown).Offset(0, 19))
cell.Value = cell.Value
Next cell
With Range("U2", Range("B2").End(xlDown).Offset(0, 19))
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.NumberFormat = "m/d/yyyy"
End With
'''''TRACKING NUMBER
With Range("V2", Range("B2").End(xlDown).Offset(0, 20))
.Formula = "=INDEX('" & trPath & "'!J:J, MATCH($A2&$D2,'" & trPath & "'!A:A,FALSE))"
.Copy
.PasteSpecial Paste:=xlPasteValues
.Replace What:="0", Replacement:="", LookAt:=xlWhole
.Replace What:="UPS", Replacement:="", LookAt:=xlPart
End With
'''''FORMAT
Cells.Font.Color = RGB(0, 0, 0)
Rows(1).Font.Color = RGB(256, 256, 256)
For j = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(j, 19).Text = "Cancelled" Then
ActiveSheet.Range("R" & j).EntireRow.Font.ColorIndex = 3
ActiveSheet.Range("U" & j, "V" & j).ClearContents
End If
Next
Range("T2").Select
Application.CutCopyMode = False
EndHere:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Typically, been at this for days and as soon as I post it as a question on Stack Exchange I figure out the answer!!
Excel doesn't like doing a lookup to an external file when that file is in XLS format. This code is now snappy when I save the lookup file as an XLSX and change the reference in the variable in VBA.
Now back to the other problem of Access not wanting to export the query data as an XLSX filetype!
Edit: I added a little code to the start of the macro to open the file, save as an xlsx and close it ready for the lookup. Runs smooth as butter now :)
Sub ppmTracking()
On Error GoTo EndHere
Dim chgPath
Dim trPath
chgPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\MichPPMTracking3.xls"
trPath = "C:\Users\hbartles\Desktop\PPM\Tracking Report\[MichPPMTracking3.xlsx]MichPPMTracking3"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Workbooks.Open Filename:=chgPath
chgPath = Replace(chgPath, "xls", "xlsx")
ActiveWorkbook.SaveAs Filename:=chgPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Sheets(1).Activate
''And so on....
This question already has answers here:
Run-Time error 1004 Excel 2013
(2 answers)
Closed 6 years ago.
I'm needing to write an excel script to fill in some data. Essentially what needs to happen is the script should loop through each record and when it hits a "1" it should follow each cell with another "1" until it hits the next "1". My goal is to fill in the gaps between 1s with more 1s.
Here's what I have so far:
Dim i, j As Integer
finalrow = Cells(665, 1).End(x1up).Row
finalcol = Cells(1, 10).End(x1toleft).Column
For i = 1 To finalrow
If Cells(i, j).Value = "0" Then
For j = 1 To finalcol
Next j
Else
For j = 1 To finalcol
Next j
Cells(i, j).Value = "1"
End If
Next i
I keep getting an error when this is ran.
My data is structured like this:
0 0 1 0 0 0 1 0 0 0
1 0 0 1 0 0 0 0 0 0
0 0 0 1 0 0 1 0 0 0
0 0 0 1 1 0 0 0 0 0
Any help or advise is much appreciated.
Thanks.
There are a few issues with your code (particularly that FOR LOOP doesn't make much sense).
I took what you had and made comments and changed to quasi-fit what you are asking for.
Absorb:
Option Explicit 'USE THIS!!!
Sub Test()
'Dim i, j As Integer NO! "i" is Varaint and you want integer
Dim i As Integer, j As Integer 'Use this syntax for single line declaration
'Adding "Option Explicit" makes you declare these two variables
Dim finalRow As Integer
Dim finalCol As Integer
Dim oneFound As Boolean 'This will be used on the for loop
finalRow = Range("A65536").End(xlUp).Row 'Do this. I'm not sure your code works: Cells(665, 1).End(xlUp).Row 'you had x1, not "XL" (typo)
finalCol = Range("IV1").End(xlToLeft).Column ''Do this. I'm not sure your code works: Cells(1, 10).End(xlToLeft).Column 'had x1, not "XL" (typo)
oneFound = False
For i = 1 To finalRow 'You're looping through rows here, now you need to loop through columns
'REASON FOR YOUR ERROR: Variable j below is zero at this point and there is no cell (1,0).
'If Cells(i, j).Value = "0" Then
For j = 1 To finalCol
If Cells(i, j).Value = 1 And Not oneFound Then 'We found a one in a cell and we haven't started in filling ones yet
oneFound = True
ElseIf Cells(i, j).Value <> 1 And oneFound Then 'You found a one previously in the row and you want to start filling in data
Cells(i, j).Value = 1
ElseIf Cells(i, j).Value = 1 And oneFound Then 'You found a one previously in the row and you just found your next one
'Don't know what you want to do here
'Setting oneFound to false in case you want to stop filling in data
oneFound = False
Else
'All scenarioes should be covered for what you asking above.
'You could do something else here should you find the need
End If
Next j
oneFound = False 'Reinitialize for next row
Next i
End Sub
If all you are trying to do is replace zeros with ones, instead of looping through the data you could use search and replace functionality.
Cells.Select
Selection.Replace What:="0", Replacement:="1"
Sub abc()
j = 2
ActiveSheet.Range("a1").Select
ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row
'/// column a
ActiveSheet.Range("a3:a" & lastrow).Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$A$" & lastrow).AutoFilter Field:=1, Criteria1:="="
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
lrow = ActiveSheet.Range("A65536").End(xlUp).Row
ActiveSheet.Range("a" & lrow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Selection.AutoFilter
'column b///////////
ActiveSheet.Range("b3:b" & lastrow).Select
Selection.AutoFilter
ActiveSheet.Range("$b$1:$b$" & lastrow).AutoFilter Field:=1, Criteria1:="="
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
lrow = activehseet.Range("A65536").End(xlUp).Row
ActiveSheet.Range("a" & lrow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Selection.AutoFilter
'column c////////////
ActiveSheet.Range("c3:c" & lastrow).Select
Selection.AutoFilter
ActiveSheet.Range("$c$1:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="SG Plus", _
Operator:=xlOr, Criteria2:="=Select"
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
' Selection.Copy
' Sheets("Sheet2").Select
' lrow = activehseet.Range("A65536").End(xlUp).Row
' ActiveSheet.Range("a" & lrow).Select
' ActiveSheet.Paste
' Sheets("Sheet1").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Selection.AutoFilter
'column c again/////////////
ActiveSheet.Range("c3:c" & lastrow).Select
Selection.AutoFilter
ActiveSheet.Range("$c$1:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="="
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet2").Select
lrow = activehseet.Range("A65536").End(xlUp).Row
ActiveSheet.Range("a" & lrow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Selection.AutoFilter
'//////////////////////////// changes oct 21 end
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("a" & i).Select
If Range("a" & i).Value = "MidAmerica" Or Range("a" & i).Value = "Northeast" Or Range("a" & i).Value = "Southeast" Or _
Range("a" & i).Value = "West" Then
GoTo cont
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont:
Next i
'/////// column b ///////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("b" & i).Select
If Range("b" & i).Value = "CA" Or Range("b" & i).Value = "AZ" Then
GoTo cont2
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont2:
Next i
'///////////column c //////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("c" & i).Select
If Range("c" & i).Value = "SG" Then
GoTo cont3
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont3:
Next i
'//////////column l/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("l" & i).Select
If Range("l" & i).Value >= "01/01/2014" And Range("l" & i).Value <= "30/06/2014" Then
GoTo cont4
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont4:
Next i
'//////////column m/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("m" & i).Select
If Range("m" & i).Value >= "12/01" Or Range("m" & i).Value <= "12/05" Then
GoTo cont5
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont5:
Next i
'//////////column q and r/////////////
ActiveSheet.Range("a1").Select
For i = 3 To lastrow
Range("q" & i).Select
If Range("q" & i).Value <> " " And Range("r" & i).Value <> " " And Range("u" & i).Value <> " " _
And Range("z" & i).Value <> " " And Range("aa" & i).Value <> " " And Range("ab" & i).Value <> " " _
And Range("b" & i).Value <> " " And Range("j" & i).Value <> " " Then
GoTo cont6
Else
Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
Sheets("Sheet2").Select
Range("a" & j).Select
ActiveSheet.Paste
j = j + 1
Sheets("sheet1").Select
Selection.Delete Shift:=xlUp
End If
cont6:
Next i
End Sub
you could do that with the use of a formula and replace the existing values like this:
Sub Test2()
Dim iRow As Integer
Dim iDx As Integer
Dim iLastRow As Integer
Dim sConcatValues As String
Dim sFormula As String
sConcatValues = "A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J"
sFormula = "=LEFT(" & sConcatValues & ",FIND(""1""," _
& sConcatValues & ")) & REPT(""1"",FIND(""1""," _
& sConcatValues & ",FIND(""1""," _
& sConcatValues & ")+1)-1-FIND(""1""," _
& sConcatValues & ")) & MID(" _
& sConcatValues & ",FIND(""1""," _
& sConcatValues & ",FIND(""1""," _
& sConcatValues & ")+1),LEN(" _
& sConcatValues & "))"
iLastRow = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
iRow = 1
' put in the formula to fix the values
Range("L1:L" & iLastRow).Formula = sFormula
Range("L1:L" & iLastRow).Copy
Range("L1:L" & iLastRow).PasteSpecial xlPasteValues
' now copy over the new values, and clean up!
For iRow = 1 To iLastRow
For iDx = 1 To Len(Range("L" & iRow).Text)
Cells(iRow, iDx) = Mid(Range("L" & iRow).Text, iDx, 1)
Next
Next
Range("L1:L" & iLastRow).Clear
'Range("A1").Activate
End Sub
this is the formula that is used:
=LEFT(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)) & REPT("1",FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)+1)-1-FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)) & MID(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J,FIND("1",A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J)+1),LEN(A:A&B:B&C:C&D:D&E:E&F:F&G:G&H:H&I:I&J:J))
basically you concatenate the cells, then do a find for the first 1, followed by the next 1, and fill in between using the REPT function
Philip
Including this might help as well.
http://msdn.microsoft.com/en-us/library/office/aa213567%28v=office.11%29.aspx
Cells.SpecialCells(xlCellTypeLastCell)
Instead of using
finalRow = Range("A65536")...
finalCol = Range("IV1").End(xlToLeft).Column