Trying to just move data to another worksheet for columns with specified column names
Options Explicit
Sub tester()
With ThisWorkbook.Worksheets("Sheet1")
Dim ar As Variant
Dim i As Integer
Dim j As Long
ar = Array("Header1", "Header2") 'define header names to move
For i = 0 To UBound(ar)
j = [A1:AW1].Find(ar(i)).Column
Columns(j).Copy Sheet2.Cells(1, i + 1) 'copy to sheet2 from sheet1
Next I
End With
End Sub
But I still keep running into issues and can't debug.
Specifically - I get a compile error that says "invalid outside procedure". When I delete options explicit, I get the runtime error '13' - type mismatch
Something like this:
Sub tester()
With ThisWorkbook.Worksheets("Sheet1")
Dim ar As Variant
Dim i As Long
Dim j As Long
Dim f As Range
ar = Array("Header1", "Header2") 'define header names to move
For i = 0 To UBound(ar)
Set f = Nothing '<< added
Set f = .Range("A1:AW1").Find(arr(i), lookat:=xlwhole)
If Not f Is Nothing Then
f.EntireColumn.Copy Sheet2.Cells(1, i + 1) '<< entirecolumn
End If
Next i
End With
End Sub
Related
I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.
https://i.imgur.com/E2HEdXF.png
What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.
I don't think there is a simple method for doing this, so I was thinking of 2 possible ways
I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.
or
Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.
I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.
However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.
Copy and Sort
The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
Adjust the values in the constants section.
Option Explicit
Sub copyAndSort()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const yCols As String = "E:G"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim yrg As Range
Dim rCount As Long
Dim cCount As Long
With sws.Range(sFirst)
Dim rOff As Long: rOff = .Row - 1
Dim sCell As Range
Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub
rCount = sCell.Row - rOff
Set srg = .Resize(rCount)
Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
cCount = yrg.Columns.Count
End With
Dim sData As Variant: sData = srg.Value
ReDim Preserve sData(1 To rCount, 1 To 2)
Dim yData As Variant: yData = yrg.Value
Dim Result As Variant: ReDim Result(1 To cCount)
Dim c As Long, r As Long
For c = 1 To cCount
Result(c) = sData
For r = 1 To rCount
Result(c)(r, 2) = yData(r, c)
Next r
Next c
Erase yData
Erase sData
Dim dws As Worksheet
Dim drg As Range
Dim dName As String
Application.ScreenUpdating = False
For c = 1 To cCount
dName = Result(c)(1, 2)
On Error Resume Next
Set dws = Nothing
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
Set drg = dws.Range(dFirst).Resize(rCount, 2)
drg.Value = Result(c)
drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
Next c
wb.Save
Application.ScreenUpdating = True
End Sub
I have two sheets in my excel PullData and AllStocks. I would like to copy data from PullData column A and paste the values reverse order into other sheet AllStocks.
Currently, I am using OFFSET function to perform it. But I see a performance issue while running large data set using this method. Is there any better way I can perform this task ?
My CUrrent Code :
Sub GetData()
Dim Main As Worksheet
Dim PullData As Worksheet
Dim AllStocks As Worksheet
Dim i,m As Integer
Set RawImport = Workbooks("vwap.xlsm").Sheets("RawImport")
Set PullData = Workbooks("vwap.xlsm").Sheets("PullData")
m = PullData.Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To m
AllStocks.Range("A2:A" & i).Formula = "=OFFSET(PullData!$A$" & m & ",-(ROW(PullData!A1)-1),0)"
Next i
End Sub
no loop code:
Option Explicit
Sub GetData()
Dim pullDataVals As Variant
With Workbooks("vwap.xlsm")
With .Sheets("PullData")
pullDataVals = Split(StrReverse(Join(Application.Transpose(.Range("A3", .Cells(.Rows.Count, "A").End(xlUp)).Value), ",")), ",")
End With
.Sheets("RawImport").Range("A2").Resize(UBound(pullDataVals) + 1).Value = Application.Transpose(pullDataVals)
End With
End Sub
just check your sheets names: in your question you're speaking about "PullData and AllStocks" but in your code some RawImport sheet is featuring...
or, in a super compressed style:
Sub GetData()
With Workbooks("vwap.xlsm").Sheets("PullData")
With .Range("A3", .Cells(.Rows.Count, "A").End(xlUp))
.Parent.Parent.Sheets("RawImport").Range("A2").Resize(.Rows.Count).Value = Application.Transpose(Split(StrReverse(Join(Application.Transpose(.Value), ",")), ","))
End With
End With
End Sub
should your data in PullData be a more than one character string or more than one digit number, to prevent what Gary's Student remarked, you could use ArrayList object and its Reverse method:
Sub GetData()
Dim arr As Object
Dim cell As Range
Set arr = CreateObject("System.Collections.Arraylist")
With Workbooks("vwap.xlsm")
With .Sheets("PullData")
For Each cell In .Range("A3", .Cells(.Rows.Count, "A").End(xlUp))
arr.Add cell.Value
Next
End With
arr.Reverse
.Sheets("RawImport").Range("A2").Resize(arr.Count) = Application.Transpose(arr.toarray)
End With
End Sub
This solution applies the INDEX formula to a temporary Name.
Sub Range_ReverseOrder()
Const kFml As String = "=INDEX(_Src,#RowsSrc+#RowTrg-ROW(),1)"
Dim nmSrc As Name, rgTrg As Range
Dim lRows As Long, sFml As String
Rem Set Objects
With Workbooks("vwap.xlsm")
lRows = .Worksheets("PullData").Cells(Rows.Count, 1).End(xlUp).Row
Set nmSrc = .Names.Add(Name:="_Src", _
RefersTo:=.Worksheets("PullData").Cells(2, 1).Resize(-1 + lRows, 1))
.Names("_Src").Comment = "Range_ReverseOrder"
Set rgTrg = .Worksheets("RawImport").Cells(2, 1).Resize(-1 + lRows, 1)
End With
Rem Set Formula
sFml = kFml
sFml = Replace(sFml, "#RowsSrc", nmSrc.RefersToRange.Rows.Count)
sFml = Replace(sFml, "#RowTrg", rgTrg.Row)
Rem Apply Formula
With rgTrg
.Offset(-1).Resize(1).Value = "Reverse.Order"
.Formula = sFml
.Value2 = .Value2
End With
Rem Delete Temporary Name
nmSrc.Delete
End Sub
Would the below code be able to be modified to
remove multiple rows based on column headers and cell values, and
do this for multiple column row combinations?
example: Column "Status" Value "Complete"
Cycle through all sheets and look for any header that says status and delete all rows where status has a complete in it?
Sub Delete_Rows_Based_On_Header_and_Value ()
'
' Delete_Rows_Based_On_Header_and_Value Macro
'
' Declaration
Dim a as long
Dim w as long
Dim vDELCOLs as variant
Dim vCOLNDX as variant
Dim vDELROWs as variant
Dim vROWNDX as variant
vDELCOLs = array("status","Status Name","Status Processes")
vDELROWs = array("Complete","Completed","Done")
with Activeworkbook
for w=1 to .worksheets.count
with worksheets(w)
' I know this part is to delete columns based on the column name and I am not sure how to modify it to just check column name then delete row based on the value on that column only.
for a=lbound(vdelcols) to ubound(vdelcols)
vcolndx=application.match(vdelcols(a), .rows(1), 0)
if not iserror(vcolndx) then
.columns(vcolndx).entirecolumn.delete
end if
next a
end with
next w
end with
The following code will take an array of arrays as vDELROWS and will delete a row if any of the values match what is in the corresponding column.
Sub Delete_Rows_Based_On_Header_and_Value()
'
' Delete_Rows_Based_On_Header_and_Value Macro
'
' Declaration
Dim a As Long
Dim w As Long
Dim vDELCOLs As Variant
Dim vCOLNDX As Variant
Dim vDELROWs As Variant
Dim vROWNDX As Variant
Dim r As Long
Dim v As Long
vDELCOLs = Array("status", "Status Name", "Status Processes")
vDELROWs = Array(Array("Complete", "Pending"), Array("Completed", "Pending"), Array("Done"))
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With Worksheets(w)
For a = LBound(vDELCOLs) To UBound(vDELCOLs)
vCOLNDX = Application.Match(vDELCOLs(a), .Rows(1), 0)
If Not IsError(vCOLNDX) Then
For r = .Cells(.Rows.Count, vCOLNDX).End(xlUp).Row To 1 Step -1
For v = LBound(vDELROWs(a)) To UBound(vDELROWs(a))
If .Cells(r, vCOLNDX).Value = vDELROWs(a)(v) Then
.Rows(r).EntireRow.Delete
Exit For
End If
Next
Next
End If
Next a
End With
Next w
End With
End Sub
Autofilter is more efficient than looping
Sub DeleteRows()
Sheet1.Range("a1:c35").AutoFilter Field:=2, Criteria1:="Completed"
Sheet1.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Sheet1.UsedRange.AutoFilter
'repeat for each value
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I have looked through the other posts about this and have tried adapted the strategies that were recommend by using Set ActiveWorkbook and Set Active Worksheet and I still get the same error. I hope another set of eyes can help out as I am still very new to VBA and I am not all that comfortable with it yet.
Basically the idea is to copy the cells from column f to column j as values as long as the cells of F do not match the cells of J. I get the row count of column E and use that as my count in the for loop.
Code is here:
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim n As Integer
Dim i As Integer
n = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
i = n
For Counter = 1 To n
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
i = i + 1
Next Counter
End Sub
Thanks for the help
Also Edit:
Link to Excel Sheet that has a before page, after first transaction sheet ,and a after second transaction sheet: https://www.dropbox.com/s/n2mn0zyrtoscjin/Rewards.xlsm
CHange this:
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
To this:
Set curCell = Sheets("Calculate").Range("F2:F" & i)
If curCell <> Sheets("Calculate").Range("$J" & i) Then
Sheets("Calculate").Range("$J:$J" &i).Value = curCell.Value
End If
May need to do some more teaking as I notice you're working with SpecialCells which essentially filters the range, so iterating For i = 1 to n... probably does not work. Maybe something like:
Dim rngCalc as Range
Set rngCalc = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants)
For each curCell in rngCalc.Cells
If curCell <> curCell.Offset(0, 4) Then
curCell.Offset(0, 4).Value = curCell.Value
End If
Next
EDIT: this sub will calculate the points for the last transaction (identified as the furthest-right column containing transactions) and write them down in column C.
Option Explicit
Sub UpdateCurrentPurchase()
Dim CalcSheet As Worksheet
Dim LastTransRange As Range, TargetRange As Range
Dim LastTransCol As Long, LastTransRow As Long
Dim PurchaseArray() As Variant
Dim Points As Long, Index As Long
'set references up-front
Set CalcSheet = ThisWorkbook.Worksheets("Calculate")
With CalcSheet
LastTransCol = .Cells(2, .Columns.Count).End(xlToLeft).Column '<~ find the last column
LastTransRow = .Cells(.Rows.Count, LastTransCol).End(xlUp).Row
Set LastTransRange = .Range(.Cells(2, LastTransCol), .Cells(LastTransRow, LastTransCol))
Set TargetRange = .Range(.Cells(2, 6), .Cells(LastTransRow, 6)) '<~ column F is the Current Purchase Col
LastTransRange.Copy Destination:=TargetRange '<~ copy last transactions to Current Purchase Col
End With
'pull purchases into a variant array
PurchaseArray = TargetRange
'calculate points
For Index = 1 To LastTransRow
Points = Int(PurchaseArray(Index, 1) / 10) '<~ calculate points
CalcSheet.Cells(Index + 1, 3) = Points '<~ write out the points amount in col C
Next Index
End Sub
ORIGINAL RESPONSE: I think the below will get you where you're going. That being said, it seems like simply overwriting column J with column F (as values) might be the fastest way to an acceptable answer, so if that's the case we can re-work this code to be much quicker using Range objects.
Option Explicit
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim LastRow As Long, Counter As Long
Dim cSheet As Worksheet '<~ add a worksheet reference to save some typing
'set references up front
Set cSheet = ThisWorkbook.Worksheets("Calculate")
With cSheet
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row '<~ set loop boundary
'loop that compares the value in column 6 (F) to the value in
'column 10 (J) and writes the value from F to J if they are not equal
For Counter = 1 To LastRow
If .Cells(Counter, 6).Value <> .Cells(Counter, 10).Value Then
.Cells(Counter, 10) = .Cells(Counter, 6)
End If
Next Counter
End With
End Sub