The sort code is not working anymore. It worked the first time. Then I closed it and opened it and then it gave me an error. (I didn't change anything.) It gave me:
Error 438: Object doesn't support this property or method
On this line:
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal`
Snippet of sort code:
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Entire Code:
Sub iGetData()
Dim ValidatorWB As Workbook
Dim PopDetail As Worksheet
Dim DataSheetName As String
Dim DataWB As Workbook
Dim DataSheet As Worksheet
Dim Ret
Dim DWBName As String
Dim FNOrder As String
Dim FNOrdCol As String
Set PopDetail = Worksheets("PopulateWireframe")
Set ValidatorWB = Workbooks(ActiveWorkbook.Name)
DataSheetName = Range("F18").Value
FNOrder = Range("F33").Value
Application.ScreenUpdating = False
'Open data file
Ret = IsWorkBookOpen(PopDetail.Range("C18").Value)
If Ret = False Then
Workbooks.Open PopDetail.Range("C18").Value
DataFileName = ActiveWorkbook.Name
Set DataWB = Workbooks(DataFileName)
Set DataSheet = Worksheets(DataSheetName)
Dim FilterColumn As String
Dim FilterCriteria As String
Dim ColumnNumber As Integer
'Set filter
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
Else
DWBName = GetFilenameFromPath(PopDetail.Range("C18").Value)
Set DataWB = Workbooks(DWBName)
DataWB.Activate
Set DataSheet = Worksheets(DataSheetName)
DataSheet.Activate
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
'DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
End If
End Sub
If the debugging info shows that the FNOrder variable is correctly assigned, then this shortened version of your sort code should be all that you require.
debug.print FNOrder & " is the name of the column to be sorted on"
With DataSheet
With .Cells(1, 1).CurrentRegion
.Cells.Sort Key1:=.Columns(Application.Match(FNOrder, .Rows(1), 0)), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Cells.Copy
End With
End With
If DataSheet has been properly defined, you do not need to specify the parent workbook.
At the end of that code section, the data should be sorted and 'on-the-clipboard'. You still need to add a new worksheet to the ValidatorWB workbook and paste the values.
If that crashes, check the VBE's Immediate window (e.g. Ctrl+G) to see what was reported as being the value of FNOrder.
If you get this running to your satisfaction, I would recommend posting it in Code Review (Excel) for optimization tips.
Fixed. I changed DataWB.DataSheet in all references to just ActiveSheet. Thank you for the help.
Related
everyone. I am newie on this, but i need this so i am asking for your help.
I am building a macro to copy filtered data from several books to a consolitation one. The following code run fine until one filtered worksheet has no result rows, then it copy a range of empty cells, in that moment a receive an error 1004 that a can't solve. This is my code (result of several adaptation of code to my need):
Sub MergeDataFromWorkbooks()
Dim wbk As Workbook
Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim Filename As String
Dim Path As String
Path = "D:\Reportes\Prueba\"
Filename = Dir(Path & "*.xlsx")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & Filename)
wbk.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
wbk.Close True
Filename = Dir
Loop
MsgBox "All the files are copied and pasted in Merged."
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
you have to check whether there are any filtered cells, so wrap copy/paste statements inside some If - Then as follows:
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
If Application.WorksheetFunction.Subtotal(103, Intersect(ActiveSheet.UsedRange, Columns(2))) > 1 Then
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
End If
wbk.Close True
Filename = Dir
Check for visible values in the filtered range before copying.
With ActiveSheet
.AutoFilterMode = False
with .Range("B6:BB6")
.AutoFilter field:=8, Criteria1:="*Nacional*"
with .resize(.rows.count-1, .columns.count).offset(1, 0)
if cbool(application.subtotal(103, .cells)) then
.SpecialCells(xlCellTypeVisible).copy
end if
end with
end with
End With
It's probably better to work out the destination beforehand and use the Destination parameter of the copy operation.
I recently joined, and am looking forward to working with the community!
This is my first VBA project ever. I have a project building a macro, and it requires using several vlookup formulas. The formula looks on subsequent tabs for a translation. So, for values on tab 1 column 1, it looks on tab 2; for tab 1 column 2, it looks on tab 3 and so on.
The problem is that the lookup seems to be functioning more as a "find/replace" instead of a true lookup for exact matches only. Below, is what my research has gotten me to so far. I know there is much to learn - please help!
Thanks!
'Insert Crosswalk columns
Columns("H:H").Insert
Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_1"
Columns("J:J").Insert
Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_2"
Columns("K:K").Insert
Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
'Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_3"
Here is the FULL macro - I assume the issue is with the lookups, but I may well be wrong!
Sub MainMacro()
If MsgBox("Before starting, ensure Entity ID is ascending", vbYesNo, "Input Required") = vbYes Then
MsgBox "Please do not use Excel while this macro is running."
Dim Rng As Range
'Insert "Formula" columns
Columns("C:C").Insert
Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Formula1"
Columns("D:D").Insert
Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Formula2"
Columns("E:E").Insert
Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Concatenate1"
'Insert Crosswalk columns
Columns("H:H").Insert
Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_1"
Columns("J:J").Insert
Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_2"
Columns("K:K").Insert
Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_3"
'Copy&Paste Values
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
'Clean-up & Final Formatting
Range("G1").Select
Range("G1").Cut Destination:=Range("H1")
Range("I1").Select
Range("I1").Cut Destination:=Range("J1")
Range("L1").Select
Range("L1").Cut Destination:=Range("K1")
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("G:I").Select
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
'Apply Filter to isolate duplicates
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
ActiveSheet.Range("$A:$I").AutoFilter Field:=5, Criteria1:=Array( _
"01", "10", "11"), Operator:=xlFilterValues
'Delete dupes
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Range("$A:$L").RemoveDuplicates Columns:=Array(1, 2, 6, 7, 8, 9), Header:=xlYes
'Final De-Dupe Process
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Columns("C:C").Insert
Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Formula1"
Columns("D:D").Insert
Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Formula2"
Columns("E:E").Insert
Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Duplicate Status"
'Copy&Paste Values
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Range("C1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColor = 12632256
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Replace "01", "10", "11" with "Duplicate"
Columns("C:C").Select
Selection.Replace What:="10", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="01", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="11", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Clear filter
Range("C1").Select
ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Add Key _
:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Final message for user (manually check for remaining duplicates)
Range("A1").Select
MsgBox "Macro Complete! Remaining duplicates require manual editing."
End If
End Sub
I am able to get the result that I want to get with my code which is as follows:
Sub Button1_Click()
With Worksheets("Data").Select
With Range("A11:H11").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
With Range("E11").Select
ActiveCell.FormulaR1C1 = "Seasonal Items"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
End Sub
This code is not very elegant nor is it flowing really.
What I would like it to do is automatically search for specific wording in the column B which is either Fan or Heater, then move it to the bottom, where it is separated with a row that states season items.
See the picture below of the result:
Why I want it different is due to that the stuff is flowing and changing at points... It would make it simpler and I also would like the code to be much shorter and not for me to each time physically having to check and edit the code before running it...
Thank you for taking the time to view this and if possible provide a solution.
Something like this will move the rows the way you want them, but you will need to add in the specific formatting yourself.
Sub test()
Dim lRow As Integer
Dim lrow2 As Integer
Dim i As Integer
lRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row
ActiveSheet.Cells(lRow + 1, 5).Value = "Seasonal Items"
With ThisWorkbook.ActiveSheet
For i = 2 To lRow
lrow2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row + 1
If InStr(.Cells(i, 2), "Fan") > 0 Or InStr(.Cells(i, 2), "Heater") > 0 Then
.Rows(lrow2 & ":" & lrow2).Value = .Rows(i & ":" & i).Value
.Rows(i & ":" & i).ClearContents
End If
Next i
For i = 2 To lrow2
If .Cells(i, 1).Value = "" Then
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With
End Sub
I get "subscript out of range" error on line:
Set DataSheet = Worksheets(DataSheetName)
This only happens the first time I run it. If I re-run the code after the error, the macro works fine.
Complete code:
Sub iGetData()
Dim ValidatorWB As Workbook
Dim PopDetail As Worksheet
Dim DataSheetName As String
Dim DataWB As Workbook
Dim DataSheet As Worksheet
Dim Ret
Dim DWBName As String
Dim FNOrder As String
Dim FNOrdCol As String
Set PopDetail = Worksheets("PopulateWireframe")
Set ValidatorWB = Workbooks(ActiveWorkbook.Name)
DataSheetName = Range("F18").Value
FNOrder = Range("F33").Value
Application.ScreenUpdating = False
'Open data file
Ret = IsWorkBookOpen(PopDetail.Range("C18").Value)
If Ret = False Then
Workbooks.Open PopDetail.Range("C18").Value
DataFileName = ActiveWorkbook.Name
Set DataWB = Workbooks(DataFileName)
Set DataSheet = Worksheets(DataSheetName)
Dim FilterColumn As String
Dim FilterCriteria As String
Dim ColumnNumber As Integer
'Set filter
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
Else
DWBName = GetFilenameFromPath(PopDetail.Range("C18").Value)
Set DataWB = Workbooks(DWBName)
DataWB.Activate
Set DataSheet = Worksheets(DataSheetName)
DataSheet.Activate
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
End If
End Sub
Figured out the problem. Excel usually sets a newly opened workbook as the active workbook which is why I used activeworkbook.name to define a workbook but the newly opened workbook was not being set as the active workbook.
Did this:
Workbooks.Open PopDetail.Range("C18").Value
DataFileName = GetFilenameFromPath(PopDetail.Range("C18").Value)
Set DataWB = Workbooks(DataFileName)
DataWB.Activate
Set DataSheet = Worksheets(DataSheetName)
Instead of:
Workbooks.Open PopDetail.Range("C18").Value
DataFileName = ActiveWorkbook.Name
Set DataWB = Workbooks(DataFileName)
Set DataSheet = Worksheets(DataSheetName)
GetFilename Code:
Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
I have written a macro that to return specific values in one cell based on a vlookup of the concatenated values of two other cells. This macro may need to run in every other column for 30 columns. Is there a way that I can loop this, so that I don't have to type out 30 variations?
Here is the section of code that I am referencing:
Cells.Select
ActiveWorkbook.Worksheets("Vendor Request").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Vendor Request").Sort.SortFields.Add Key:=Range( _
"F2:F" & LR2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Vendor Request").Sort
.SetRange Range("A1:BK" & LR2)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If Cells(2, 6).Value <> "" Then
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(""Example: "",IF(ISNA(VLOOKUP(CONCATENATE(RC[-4],""; "",RC[-1]),'Sample Data'!C[-6]:C[-2],5,FALSE)),"""",VLOOKUP(CONCATENATE(RC[-4],""; "",RC[-1]),'Sample Data'!C[-6]:C[-2],5,FALSE)))"
If Cells(3, 6).Value <> "" Then
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & Range("F" & Rows.Count).End(xlUp).Row)
Else
End If
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
End If
Thanks in advance!
Edit: Finally got it working. Here is what I ended up with:
Cells.Select
ActiveWorkbook.Worksheets("Vendor Request").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Vendor Request").Sort.SortFields.Add Key:=Columns( _
j - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Vendor Request").Sort
.SetRange Range("A1:BK" & LR2)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim LRj As Long
With Sheets("Vendor Request")
LRj = .Cells(.Rows.Count, j - 1).End(xlUp).Row
End With
If Cells(2, j - 1).Value <> "" Then
Cells(2, j).Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(""Example: "",IF(ISNA(VLOOKUP(CONCATENATE(c3,""; "",C[-1]),'Sample Data'!c1:c6,5,FALSE)),"""",VLOOKUP(CONCATENATE(c3,""; "",C[-1]),'Sample Data'!c1:c6,5,FALSE)))"
If Cells(3, j - 1).Value <> "" Then
Cells(2, j).Select
Selection.AutoFill Destination:=Range(Cells(2, j), Cells(LRj, j))
Else
End If
Columns(j).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
End If
Next j
you can change ...Range("G2:G... to Range("G2:AK and Columns("G:G" to Columns("G:AK"
or Range(Cells(2,j),Cells(...,j)) inside a for loop