Related
Excel 2013
I have 3 worksheets in this workbook, its highly formatted and I used a custom formula I coded in VBA that utilizes Application.Volatile so it automatically refreshes the calculations every time you enter new data.
My team has formatted this workbook up and down and created a huge tracker that contains financials for our company. The problem is that now when we go to open the workbook and hit f9/load the calculate sheet function, only the selected worksheet will update and calculate based on its reference cells within that sheet.
It's supposed to do this, but the problem is inside of the other two tabs(mind you there are 3 total), the cells that have formulas will revert back to either all zeros or old data that is currently not applicable. When you select one of the other two tabs that initially were not selected and hit f9/load calculate sheet function the cells with functions that once had the zeros/old data inside them update based on the new values that the cell is referencing, and it works fine.
It keeps doing this as we switch tabs and reinitialize the f9/calculate sheet function, the other two tabs that are currently not selected reset and display either all zeros or old data. I have been googling and looking everywhere for a solutions and nothing has worked.
Function RedFinder(MyCellColumn As Integer, MyOffset As Integer, MonthCheck As Integer, YearCheck As Integer)
Application.Volatile
' Dim MyCellRow As Integer 'row I want to select
Dim MyMoneyValue As Variant 'Single holds a decimal variable
Dim MyAnswerString As String
' Sheets("Sheet1").Activate 'activate sheet1 at cell script runs on
' MyCellRow = 115 'set variable MyCellRow to row 1
MyMoneyValue = CDec("0.0")
' ActiveSheet.Cells(MyCellRow, MyCellColumn).Select 'select active cell based on input vars
For MyCellRow = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'for loop used to go through all cells
If IsDate(ActiveSheet.Cells(MyCellRow, MyCellColumn)) Then 'checks if cell is a date
If Month(ActiveSheet.Cells(MyCellRow, MyCellColumn)) = MonthCheck And Year(ActiveSheet.Cells(MyCellRow, MyCellColumn)) = YearCheck Then 'checks if month and date match
If IsNumeric(ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset)) Then 'checks if corresponding column is a number
If ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset).Font.Color = 255 Then 'checks if cell text color is red, 255 is the number Font.Color returns for RGB Red (255,0,0)
MyMoneyValue = MyMoneyValue + ActiveSheet.Cells(MyCellRow, MyCellColumn).Offset(0, MyOffset) 'adds cell value to MyMoneyValue
' MyAnswerString = MyMoneyValue
' MyCellRow = MyCellRow + 1
' Else
' MyCellRow = MyCellRow + 1
End If
End If
' Else
' MyAnswerString = "False"
' MyCellRow = MyCellRow + 1
End If
End If
Next MyCellRow
'MsgBox MyCellColumnA
'RedFinder = Year(ActiveSheet.Cells(MyCellRow, MyCellColumn))
RedFinder = MyMoneyValue 'sets function to report total of MyMoneyValue
End Function
You need to remove all of the ActiveSheet references and replace them with a reference to the sheet containing the formula which calls your UDF
Function RedFinder(MyCellColumn As Integer, MyOffset As Integer, MonthCheck As Integer, YearCheck As Integer)
Application.Volatile
Dim MyMoneyValue As Variant 'Single holds a decimal variable
Dim MyAnswerString As String
Dim sht As Worksheet, c As Range, MyCellRow As Long
Set sht = Application.Caller.Parent '<<<< or use Application.ThisCell.Parent
MyMoneyValue = CDec("0.0")
For MyCellRow = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
Set c = sht.Cells(MyCellRow, MyCellColumn)
If IsDate(c.Value) Then
If Month(c.Value) = MonthCheck And Year(c.Value) = YearCheck Then 'checks if month and date match
If IsNumeric(c.Offset(0, MyOffset)) Then
If c.Offset(0, MyOffset).Font.Color = 255 Then
MyMoneyValue = MyMoneyValue + c.Offset(0, MyOffset)
End If
End If
End If
End If
Next MyCellRow
RedFinder = MyMoneyValue
End Function
I wrote the below macro in Excel (2010) VBA to add markers to contracts with various issues to a master tracker. While doing some size testing I am getting error 400 when I attempt to run with an input of 50,000 contracts (array Contracts), but it runs fine with 40,000 (took about 14 minutes). Any ideas at why I am getting the error? Commented in the code where it is stopping at 50,000. Thank you!
Sub UploadNew()
''''''''''''''''''''''''Add All Contracts to End of Master'''''''''''''''''''''''''''''''
'Set up the array Contracts which will house the new contracts to be uploaded
Dim Contracts() As String
Dim size As Long
Dim R As Integer
Dim N As Long
'This sets up the value for N as the end of the current master list
N = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
'Determine size of array and store it into variable size
size = Worksheets("Update").Cells(Rows.Count, "A").End(xlUp).Row - 1
'Identifies which Remediation column to add the marker to
R = Application.WorksheetFunction.VLookup(Worksheets("Update").Range("F2"), Range("E14:G263"), 3, False)
'Having counted size we can redimension the array
ReDim Contracts(size)
'Insert the values in column A into the array
Dim i As Long
For i = 1 To size
Contracts(i) = Range("A1").Offset(i)
Next i
'Takes each value in the array and adds it to the end of the master list using N
For i = 1 To size
Worksheets("Master").Range("A" & N).Value = Contracts(i)
N = N + 1
Next i
'Remove the duplicates from the master tab based on the first column
Worksheets("Master").Range("A:ZZ").RemoveDuplicates Columns:=Array(1)
'Remove blank rows from Master
Dim rng As Range
Set rng = Worksheets("Master").Range("A2:A" & N).SpecialCells(xlCellTypeBlanks)
rng.EntireRow.Delete
''''''''''''''''''''''''Add All Contracts to End of Master'''''''''''''''''''''''''''''''
'''''''''''''''''''''Place New Contract Marker for Each Contract'''''''''''''''''''''''''
'This searches all the contracts in the master and places a 1 R columns to the right of
'the found contract
For i = 1 To size
Dim rgFound As Range
Set rgFound = Worksheets("Master").Range("A2:A" & N).Find(Contracts(i))
'! Code is stopping about here with 50,000 contracts, doesn't add a single marker !'
With rgFound.Offset(, R)
.Value = "1"
.NumberFormat = "General"
End With
Next i
'''''''''''''''''''''Place New Contract Marker for Each Contract'''''''''''''''''''''''''
End Sub
This rewrite bulk loads and bulk unloads the array. I've swapped out a worksheet MATCH function for the Range.Find method since there should be guaranteed matches.
Sub UploadNew()
''''''''''''''''''''''''Add All Contracts to End of Master'''''''''''''''''''''''''''''''
'Set up the array Contracts which will house the new contracts to be uploaded
Dim Contracts As Variant
Dim i As Long, N As Long, R As Integer
With Worksheets("Update")
'Identifies which Remediation column to add the marker to
'I have no idea why you are looking up F2 in column E (and returning value from column G) on the Updates worksheet
R = Application.WorksheetFunction.VLookup(.Range("F2"), .Range("E14:G263"), 3, False)
'AT THIS POINT R SHOULD BE AN INTEGER BETWEEN 2 and 16384
'NOT LARGER OR SMALLER OR TEXT
'CHECK WITH A WATCH WINDOW!!!!!!!!!!!
'Insert the values in column A into the array (SKIP HEADER ROW)
Contracts = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Value2
End With
With Worksheets("Master")
'This sets up the value for N as the end of the current master list
N = .Cells(Rows.Count, "A").End(xlUp).Row + 1
'Takes each value in the array and adds it to the end of the master list using N
.Range("A" & N).Resize(UBound(Contracts, 1), UBound(Contracts, 2)) = Contracts
'Remove the duplicates from the master tab based on the first column
.Range("A:ZZ").RemoveDuplicates Columns:=Array(1)
'Remove blank rows from Master
If CBool(Application.CountBlank(.Range("A2:A" & N))) Then _
.Range("A2:A" & N).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
''''''''''''''''''''''''Add All Contracts to End of Master'''''''''''''''''''''''''''''''
'''''''''''''''''''''Place New Contract Marker for Each Contract'''''''''''''''''''''''''
'This searches all the contracts in the master and places a 1 R columns to the right of
'the found contract
For i = LBound(Contracts, 1) To UBound(Contracts, 1)
With .Cells(Application.Match(Contracts(i, 1), .Columns(1), 0), R)
.Value = "1"
.NumberFormat = "General"
End With
Next i
End With
'''''''''''''''''''''Place New Contract Marker for Each Contract'''''''''''''''''''''''''
End Sub
btw, regarding Dim rgFound As Range ; do not declare a variable in a loop. Declare it outside the loop and assign it new values inside the loop.
I am super new to VBA. I am working on a problem where I am looping and creating a sentence, but I am having a problem with an overflowing row. Can you explain where i went wrong?
Sub clue()
Dim name, room, weapon As String
Dim can, dag, lead, rev, rop, wre, total, least As Double
Dim row As Integer
Cells(1, 1).Activate
cam = 0
dag = 0
lead = 0
rev = 0
rop = 0
wre = 0
row = 1
Do Until IsEmpty(ActiveCell)
name = ActiveCell.Value
room = ActiveCell.Offset(1, 0).Value
weapon = ActiveCell.Offset(2, 0).Value
Cells(row, 3).Value = name & " in the " & room & " with the " & weapon & "."
If weapon = "Candlestick" Then
can = can + 1
End If
If weapon = "Dagger" Then
dag = dag + 1
End If
If weapon = "Lead Pipe" Then
lead = lead + 1
End If
If weapon = "Revolver" Then
rev = rev + 1
End If
If weapon = "Rope" Then
rop = rop + 1
End If
If weapon = "Wrench" Then
wre = wre + 1
End If
ActiveCell.End(xlDown).End(xlDown).Activate
row = row + 1
Loop
total = can + dag + lead + rev + rop + wre
Cells(2, 6) = can
Cells(3, 6) = dag
Cells(4, 6) = lead
Cells(5, 6) = rev
Cells(6, 6) = rop
Cells(7, 6) = wre
Cells(2, 7) = can / total
Cells(3, 7) = dag / total
Cells(4, 7) = lead / total
Cells(5, 7) = rev / total
Cells(6, 7) = rop / total
Cells(7, 7) = wre / total
least = 1000000000
If can < least Then least = can
If dag < can Then least = dag
If lead < dag Then least = lead
If rev < lead Then least = rev
If rop < rev Then least = rop
If wre < rop Then least = wre
Cells(10, 5) = least
End Sub
I am trying to print out a sentence on a row using certain inputs, but as the inputs change I want to print the next sentence on the next row (hence the row=row+1) but it keeps saying that there is an "overflow" problem and i need to change something but I don't know why. Does anyone know?
Thanks!
You probably have an overflow once you have read 32K rows
and it happens because you declared your row variable as integer.
Change it to long and you will be able to work on 2 billions rows
Dim row As Long
Try to remember this :
Byte between 0 and 255.
Integer between -32,768 and 32,767.
Long between – 2,147,483,648 and 2,147,483,647.
Currency between -922,337,203,685,477.5808 and 922,337,203’685,477.5807.
Single between -3.402823E38 and 3.402823E38.
Double between -1.79769313486232D308 and 1.79769313486232D308.
Row returns a Long, not an Integer
Note that
Dim name, room, weapon As String
only defines weapon as string, the rest is variant.
The correct syntax is
Dim name as string, room as string, weapon As String
I liked the "game" purposed question and, since you declare yourself "a super new to VBA", I think it can help you the following refactoring of your initial code
Option Explicit
Sub clue()
Dim can As Long, dag As Long, lead As Long, rev As Long, rop As Long, wre As Long, row As Long
Dim weapon As String
Dim roomsRng As Range, areaRng As Range, roomsReportRng As Range, finalStatsRng As Range, leastStatsRng As Range ' these are useful range variable. you'll set them and use to avoid loosing control over what you're actually handling
' here follows a section dedicated to setting relevant "ranges". this helps a lot in avoiding loosing control over what you're actually handling
With ActiveSheet 'always explicitly qualify which worksheet do you want to work with. "ActiveSheet" is the currently active one, but you may want to qualify 'Worksheets("MySheetName")'
Set roomsRng = .Range("A1:A" & .cells(.Rows.Count, 1).End(xlUp).row) 'set roomsRng range as the one collecting activesheet cells in column "A" down to the last non empty one
Set roomsRng = roomsRng.SpecialCells(xlCellTypeConstants, xlTextValues) 'select only non blank cells of "roomsRng" range (skip blanks)
Set roomsReportRng = .cells(1, 3) ' set the range you start writing rooms report from
Set finalStatsRng = .Range("F2") ' set the range you'll start writing final stats from
Set leastStatsRng = .Range("E10") ' set the range you'll write the least found weapon number in
End With
For Each areaRng In roomsRng.Areas 'loop through all "Areas" of "roomsRng" range cells: an "Area" is a group of contiguous cells
Call WriteRoomsReport(areaRng.cells, roomsReportRng, row, weapon) 'write room report
Call UpdateWeaponsStats(weapon, can, dag, lead, rev, rop, wre) ' update weapons statistics
Next areaRng
Call WriteFinalStats(can, dag, lead, rev, rop, wre, finalStatsRng, leastStatsRng) ' write final statistics
End Sub
Sub WriteRoomsReport(roomCells As Range, reportCell As Range, row As Long, weapon As String)
Dim arr As Variant 'it'll be used as an array, see below
arr = Application.Transpose(roomCells) 'initialize the Variant as an array, filling it up with "roomCells" range content
reportCell.Offset(row).Value = arr(1) & " in the " & arr(2) & " with the " & arr(3) & "." 'write the report line
weapon = arr(3) ' store the weapon value to pass back to calling sub
row = row + 1 'update the row for subsequent use
End Sub
Sub UpdateWeaponsStats(weapon As String, can As Long, dag As Long, lead As Long, rev As Long, rop As Long, wre As Long)
' use "Select Case" pattern to avoid multiple and unuesful If-then repetition
' once a "case" is hit, its correspondant statements will be processed and then control passes to the statement following the "End Select" one
Select Case weapon
Case "Candlestick"
can = can + 1
Case Is = "Dagger"
dag = dag + 1
Case "Lead Pipe"
lead = lead + 1
Case Is = "Revolver"
rev = rev + 1
Case "Rope"
rop = rop + 1
Case Is = "Wrench"
wre = wre + 1
End Select
End Sub
Sub WriteFinalStats(can As Long, dag As Long, lead As Long, rev As Long, rop As Long, wre As Long, finalStatsRng As Range, leastStatsRng As Range)
Dim total As Long, least As Long
Dim weaponArr As Variant
total = can + dag + lead + rev + rop + wre
weaponArr = Array(can, dag, lead, rev, rop, wre)
With finalStatsRng.Resize(6) ' select a range of 6 cells in one clolumn, starting from the passed "finalStatsRng" range and resizing it up to enclose the subsequent 5 cells below it
.Value = Application.Transpose(weaponArr) ' fill the selected range (using ".Value" property of the "Range" object) with the "array" technique
With .Offset(, 1) ' shift one column to the right of selected range
.FormulaR1C1 = "=RC[-1]/" & total ' write in all cells a formula that takes the value form the adjacent cell and divide it by the "total" variable value
.Value = .Value ' have formulas replaced with values. you can comment this and cells will remain with formulas (they show the resulting values, but if you select one of them you'll see a formula in the formula ribbon of Excel UI
End With
End With
leastStatsRng.Value = Application.WorksheetFunction.Min(weaponArr) 'get the minimum value of all passed values calling the "MIN" function (which belongs to "WorksheetFuncion" object of the "Application" object -Excel) over the array filled with weapon countings
End Sub
the above code pattern has the following aims:
break code into specific functions or subs
to let you both better control the flow of your code by means of the "main" sub (that should be a sequence of statements like "Call DoThis()", "Call DoThat()" , ...) and concentrate on specific subs/functions to handle specific job
thus leading to a much more easily maintainable and "debuggable" code
use only some (out of the many) relevant VBA and Excel VBA techniques, like using Range object (see Resize(), Offset(), End(), SpecialCells() methods), Arrays (via Variant type variable), WorksheetFunction object.
of course you'll need to study all of those techniques (and many others!) exploiting such resources as SO itself, MSDN site (https://msdn.microsoft.com/en-us/library/office/ee861528.aspx) and many others you easily get in the web just googling a significant issue
as a final (and sad) note, I must warn you: building a game is something that would eventually lead towards "true" OOP, like VBA is not.
should "building games" be your true aim, then you'd better switch immediately to some true OOP language, like C#, and correspondent IDE, like Visual Studio (whose Community Edition version is currently free)
I was having some trouble with a macro I have been writing. I am trying to find a match in column A and column D. When I detect a match I want to copy the adjacent cells of each I.E copy the contents of B of the line of the first match to E where the match occurs in D. Whenever I do this I never get the right copy. It will copy the values that match but put them in the completely wrong space. I only encounter a problem when the order is mixed up or there is a white space. Any suggestions would be helpful.
Thanks
Nick.
Note: In this version of my code I was using input boxes to pick what two columns of data the user wants to compare and the one he wants to copy from and paste too. It should not make a big difference.
Sub Copy()
Dim column1 As String
Dim column2 As String
Dim from As String
Dim too As String
numrows = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
'MsgBox numrows
column1 = InputBox("which column do you want to select from")
column2 = InputBox("which column do you want to compare to ")
from = InputBox("which column do you want to copy data from")
too = InputBox("which column do you want to copy data to")
Dim lngLastRow As Long
Dim lngLoopCtr As Long
Dim i As Long
Dim j As Long
Dim value As String
lngLastRow = Range(column1 & Rows.Count).End(xlUp).Row
lngLastRow2 = Range(column2 & Rows.Count).End(xlUp).Row
'lngLastRow = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
Dim temp As String
For i = 1 To lngLastRow Step 1
temp = Cells(i, column1).value
value = Cells(i, from).value
'MsgBox "temp"
'MsgBox (temp)
If Cells(i, column1).value <> "" Then
For j = 1 To lngLastRow2 Step 1
' MsgBox "cell"
' MsgBox (Cells(j, column2).value)
If Cells(j, column2).value = "" Then
Cells(j, column2).Offset(1, 0).Select
End If
If Cells(j, column2).value <> "" Then
If temp = Cells(j, column2).value Then
'MsgBox "equal"
'MsgBox "i"
'MsgBox i
'MsgBox "j"
'MsgBox j
'value = Cells(j, from).value
'MsgBox Cells(i, too).value
'Cells(i, too).value = Cells(j, from).value
'Dim num As Integer
'On Error Resume Next
'num = Application.WorksheetFunction.VLookup(temp, Sheet1.Range("A0:M13"), 3, False)
Cells(i, too).value = Cells(j, from).value
'MsgBox j
' MsgBox (Cells(i, column1).value)
' MsgBox "="
' MsgBox (Cells(j, column2).value)
End If
End If
Next j
End If
Next i
End Sub
I have studied your text and your macro and think the macro below does what you want.
If this macro does what you want, your problem was caused by your use of meaningless variable names such as: column1, column2, i and j. This meant you did not notice you were using the wrong variables in the statement that copied values.
I have renamed all your variables. I am not asking you to like my naming convention but I am recommending you have a naming convention. I can look at macros I wrote years ago and know what all the variables are because I developed my convention in my early days of VBA programming and have used it every since. This makes my life much easier when I need to update old macros.
I have added Option Explicit at the top of the module. Without this statement, a misspelt variable name becomes a declaration:
Dim Count As Long
Lots of statements
Count = Conut + 1
This causes Conut to be declared with a value of zero. Such errors can be a nightmare to find.
I have used a With Statement to make explicit which worksheet I am using.
You checked both cells to not be empty. I only check the first because it is not necessary to check the second since, if the second is empty, it will not match the first.
Your code did not stop working down the Compare column if it found a match so my code does the same. This is correct if values can repeat in the Compare column. If they cannot repeat, you may wish to add Exit For to exit the inner loop after a match has been processed.
I believe the above explains all the changes I hve made.
Option Explicit
Sub Copy()
Dim ColCompare As String
Dim ColCopyFrom As String
Dim ColCopyTo As String
Dim ColSelect As String
Dim RowCrntCompare As Long
Dim RowCrntSelect As Long
Dim RowLastColCompare As Long
Dim RowLastColSelect As Long
Dim SelectValue As String
With Sheet1
ColSelect = InputBox("which column do you want to select ColCopyFrom")
ColCompare = InputBox("which column do you want to compare to ")
ColCopyFrom = InputBox("which column do you want to copy data ColCopyFrom")
ColCopyTo = InputBox("which column do you want to copy data to")
RowLastColSelect = .Range(ColSelect & .Rows.Count).End(xlUp).Row
RowLastColCompare = .Range(ColCompare & .Rows.Count).End(xlUp).Row
For RowCrntSelect = 1 To RowLastColSelect Step 1
SelectValue = .Cells(RowCrntSelect, ColSelect).value
If SelectValue <> "" Then
For RowCrntCompare = 1 To RowLastColCompare Step 1
If SelectValue = Cells(RowCrntCompare, ColCompare).value Then
.Cells(RowCrntCompare, ColCopyTo).value = _
.Cells(RowCrntSelect, ColCopyFrom).value
End If
Next RowCrntCompare
End If
Next RowCrntSelect
End With
End Sub
I am trying to copy specific columns by the column name and copy it to a new worksheet. I found this code online but I would like to have the cloumn names in the vba code instead of having a textbox pop up and me writing each one in at a time.
Sub copycolumns()
Dim strColRng As String
Dim strSheetName As String
Dim intNoofCols As Integer
Dim strColName() As String
Dim strCurSheetName As String
'To get the No. of Columns Available to Search
intRng = 65
'To get the No. of Columns to copy and paste
intNoofCols = 10
'To set size of the Array
ReDim Preserve strColName(intNoofCols)
For i = 0 To intNoofCols - 1
'To Get the Column Name to Search
strColName(i) = Array(Array("POS", "POS"), Array("Product Code", "Product Code"), Array("Product Name", "Product Name"), Array("Currency", "Currency"), Array("Nominal Source", "Nominal Source"), Array("Maturity Date", "Maturity Date"), Array("Nominal USD", "Nominal USD"), Array("BV Source", "BV Source"), Array("ISIN", "ISIN"), Array("Daily NII USD", "Daily NII USD"))
' InputBox("Enter the Column Name to Copy?", "Column Name")
Next
'To get the Sheet Name to paste the content
strSheetName = InputBox("Enter the Sheet Name to Paste?", "Sheet Name")
'To store the Current Sheet Name where to copy
strCurSheetName = ActiveSheet.Name
For j = 0 To intNoofCols - 1 'To get the Column Names from the Array
For i = 1 To intRng
'To Select the Sheet which column to copy
Sheets(strCurSheetName).Select
'Store the Cell Value
strVal = Cells(1, i)
'Check the Value with the User given column name
If UCase(strVal) = UCase(Trim(strColName(j))) Then
'Select and Copy
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Select and Paste
Sheets(strSheetName).Select
Cells(1, j + 1).Select
Range(Selection, Selection.End(xlDown)).PasteSpecial xlPasteValues
' ActiveSheet.Paste
End If
Next
Next
I appreciate any help. Thanks!
So, if I understand correctly, you want the strColName variable to hold the array you defined, instead of the program looping and asking the user to fill the array? In that case, use:
Dim strColName() As String
strColName = Split("POS,Product Code,Product Name,Currency,Nominal Source,Maturity Date,Nominal USD,BV Source,ISIN,Daily NII USD", ",")
Problem is, you defined the strColName as an array of Strings, and you input arrays. Also, you defined the array inside the loop, so it will execute 10 times. You can delete the redim statement, because you define the number of members of the array when you make the array.
I use this all the time
'1 = DELETE all columns IN list
'2 = DELETE all columns NOT in list
'3 = MOVE all columns IN List to NEW Sheet
'4 = MOVE all columns NOT in List to NEW Sheet
'sSource = Source Sheet for Deleting or Moving To
'tTarget = Target Sheet for Moving Columns To
'n = offset the numer of columns when moving columns n = 0 for no offset
Sub MoveOrDelete()
fDeleteOrMove 3, "MySheetNameSoure", "MySheetNameTarget", 0, Array("ColName1", "ColName2", "ColName3")
End Sub
'THIS IS THE FUNCTION FOR MOVE/DELETE
Sub fDeleteOrMove(cWhat As Integer, sSource As String, tTarget As String, n As Integer, myList As Variant)
Dim wsS As Excel.Worksheet
Dim wsT As Excel.Worksheet
Dim LC As Long
Dim mycol As Long
Dim x
ActiveWorkbook.Worksheets(sSource).Select
Set wsS = ActiveWorkbook.Worksheets(sSource) 'Source Sheet for Deleting or Moving To
Set wsT = ActiveWorkbook.Worksheets(tTarget) 'Target Sheet for Moving Columns To
'Get Last Row of "Source" Sheet
LC = wsS.Cells(1, Columns.Count).End(xlToLeft).Column
For mycol = LC To 1 Step -1
x = ""
On Error Resume Next
x = WorksheetFunction.match(Cells(1, mycol), myList, 0)
Select Case cWhat
Case 1
'Delete all columns IN list
If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Delete
Case 2
'Delete all columns NOT in list
If Not IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Delete
Case 3
'Move all columns IN List to NEW Sheet
If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
Destination:=wsT.Columns(x).Offset(, n)
Case 4
'Move all columns NOT in List to NEW SheeT
If Not IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
Destination:=wsT.Columns(mycol).Offset(, n)
'Delete the EMPTY columns that were not moved from "Target" sheet
If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
Destination:=wsT.Columns(mycol).Offset(, n).Delete
End Select
Next mycol
ActiveWorkbook.Worksheets(tTarget).Select
End Sub