Store and Paste values with a dynamic array - excel

first of all sorry for my bad english, it's not my native lang.
i have a dynamic table that changes its content when i insert a specific keynumber
The keynumber in this case is "5" and all the content of that sheet changes according to the number i enter (from 1 to 42).
What i want to do is copy all the data and paste only the values in an empty row on the same sheet.
i achieved that with the next code:
Sheets("Biblia General").Range("B8:H142").Copy
Sheets("Biblia General").Range("M8").PasteSpecial xlPasteValues
'Remove the animation around the copied cell
Application.CutCopyMode = False
Selection.Sort key1:=Range("N8")
when i press the button copiar it copies and then paste on the right of the sheet.
But now i need to do the same thing but for the whole keynumbers, for example i need to run a copy and paste of the values of all the tables for 1 to 42 not just one by one.
i don't know how to enter for example the keynumber 1 calculate the sheet then copy the content and paste the values to the right, then do it again but for keynumber 2 and so on until it ends at keynumber 42...
is there a way i can achieve that? im not realy familiar with vba but i think i need to do a dynamic array or something like that
thanks in advance

Copy Values by Assignment
When you do drg.Value = srg.Value, it is as fast as you can copy values (not formulas or formats). It is called Copying by Assignment and there is one simple rule: both ranges have to be of the same size (same number of rows and columns).
Usually, you only know the first cell of the destination range and you know it has to be of the size of the source range. Let's call the first cell dfCell. To create a reference to the destination range you will do the following:
Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
The Code
Option Explicit
Sub CopyData()
Const wsName As String = "Biblia General"
Const ClaveCount As Long = 42
Const ClaveAddress As String = "C1" ' Clave
Const LoteAddress As String = "C3" ' Lote
Const srgAddress As String = "B8:H142"
Const dfCellAddress As String = "M8"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim srg As Range: Set srg = ws.Range(srgAddress)
Dim Clave As Range: Set Clave = ws.Range(ClaveAddress)
Dim Lote As Range: Set Lote = ws.Range(LoteAddress)
Dim rCount As Long: rCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
Application.ScreenUpdating = False
dfCell.Offset(, -1).Resize(ws.Rows.Count - dfCell.Row + 1, cCount + 1) _
.ClearContents
Dim drg As Range
Dim dclrrg As Range
Dim n As Long
For n = 1 To ClaveCount
Clave.Value = n
Set drg = dfCell.Resize(rCount, cCount)
drg.Value = srg.Value
If n = 1 Then
drg.Cells(1).Offset(, -1).Value = "Lote" ' Lote
' exclude headers
rCount = rCount - 1
Set srg = srg.Resize(rCount).Offset(1)
Set drg = drg.Resize(rCount).Offset(1)
End If
drg.Columns(1).Offset(, -1).Value = Lote.Value ' Lote
drg.Sort drg.Columns(2), xlAscending, , , , , , xlNo
Set dfCell = drg.Columns(2) _
.Find("*", , xlValues, , , xlPrevious).Offset(1, -1)
Set dclrrg = drg.Resize(drg.Row + rCount - dfCell.Row) _
.Offset(dfCell.Row - drg.Row, -1).Resize(, cCount + 1)
dclrrg.ClearContents
Next n
Application.ScreenUpdating = True
MsgBox "Data copied.", vbInformation, "CopyData"
End Sub

I think it is easier without an array:
Dim i As Long
For i = 1 To 42
[D1].Value = i 'set the key number (please check the address
Sheets("Biblia General").Range("B8:H142").Copy '135 rows
'Paste each block below the previous one
Sheets("Biblia General").Range("M8").Offset((i - 1) * 135, 0).PasteSpecial xlPasteValues
'Remove the animation around the copied cell
Application.CutCopyMode = False
Selection.Sort key1:=Range("N8")
Next i

Related

VBA: faster way to change row (or cell) color based on values without referring to cell

Is there in VBA faster way to change row (or cell) color based on values without referring to cell
Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA.
Table:
Amount1
Amount2
100
50
20
200
...
...
If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.
Thank You!
It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:
Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range
Set rng = ActiveSheet.Range("A1:B1000")
rng.Formula = "=RANDBETWEEN(1,1000)"
rng.Value = rng.Value
End Sub
Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed
Dim t As Single
t = Timer
Set rng = Range("A1:B1000")
arr = rng.Value
For Each rRow In rng.Rows
i = i + 1
If arr(i, 2) > arr(i, 1) Then
clr = clrMore
Else
clr = clrLessEqual
End If
If rRow.Interior.Color <> clr Then
rRow.Interior.Color = clr
End If
Next
Debug.Print Timer - t
End Sub
Highlight Rows
Sub HighlightRows()
Dim t As Double: t = Timer
' Define constants (adjust).
Const PROC_TITLE As String = "Highlight Rows"
Const SMALL_COL As Long = 1
Const GREAT_COL As Long = 2
Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
' Reference the table range.
' Turn off screen updating.
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
' Validate rows and columns.
' Validate rows.
Dim rCount As Long: rCount = trg.Rows.Count
If rCount < 2 Then
MsgBox "No data or just headers in the range '" _
& trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Validate columns.
Dim cCount As Long: cCount = trg.Columns.Count
Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
If cCount < GREAT_COL Then
MsgBox "Column " & MaxCol & " is greater than the number " _
& "of columns (" & cCount & ") in the range ('" _
& trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Reference and populate the helper columns.
' Insert two helper columns adjacent to the right of the table range.
trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
' Remove this line if there is no data to the right.
' Reference the expanded table range (including the helper columns)...
Dim erg As Range: Set erg = trg.Resize(, cCount + 2) ' has headers
' ... and reference its data to be used with 'SpecialCells'.
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
' Reference the helper columns.
Dim CompareCol As Long: CompareCol = cCount + 1 ' for the auto filter
Dim crg As Range: Set crg = erg.Columns(CompareCol)
Dim irg As Range: Set irg = erg.Columns(cCount + 2)
' Write an ascending integer sequence to the Integer column.
irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Write the values from the criteria columns to arrays.
Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
' Define the Compare array.
Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
Dim SmallVal, GreatVal, r As Long
' Write the Compare results to the Compare array
' (1 for the 1st color and 2 for the 2nd), ...
For r = 2 To rCount ' skip headers
SmallVal = SmallData(r, 1)
GreatVal = GreatData(r, 1)
If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
Select Case SmallVal
Case Is < GreatVal: CompareData(r, 1) = 1
Case Is > GreatVal: CompareData(r, 1) = 2
End Select
End If
Next r
Erase SmallData
Erase GreatData
' ... write the results from the array to the Compare column...
crg.Value = CompareData
Erase CompareData
' ... and sort the range by it.
erg.Sort crg, xlAscending, , , , , , xlYes
' Highlight the rows.
edrg.Interior.Color = xlNone ' clear previous colors
Dim vedrg As Range
For r = 1 To 2
erg.AutoFilter CompareCol, CStr(r)
On Error Resume Next ' prevent error when no filtered rows
Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False ' turn off the auto filter!!!
If Not vedrg Is Nothing Then
Debug.Print vedrg.Address ' only two areas are being highlighted
vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
Set vedrg = Nothing ' reset for the next iteration
End If
Next r
' Clean up.
' Sort the range by the Integer column restoring initial order.
erg.Sort irg, xlAscending, , , , , , xlYes
' Delete the helper columns.
crg.Resize(, 2).Delete xlShiftToLeft
' If you have removed the Insert-line, replace this line with:
'crg.Resize(, 2).Clear
' Turn on screen updating to immediately see the changes
' (if the worksheet is active) before OK-ing the message box.
Application.ScreenUpdating = True
Debug.Print Format(Timer - t, "00.000000")
' Inform.
MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
End Sub

Unpivoting 2 categories of columns using vba

I have code that unpivots columns with the category of Line1, Line2, Line3, Line4 into one Column called Lines. This code accomplishes that goal. However, I also have other another category I want to unpivot as well but I'm not sure how to unpivot two categories at the same time. My code only unpivots one category. I want it to unpivot two: Line1, Line2, Line3, Line4 & Color1, Color2, Color3, Color4 -----> Unit Name & Color (each with their own columns). Very hard to explain, so I have attached my code and also a few tables pictures. The 2nd pic is how I want to look. As I stated before, the code works to unpivot Columns H-K (s/o to VBasic 2008 for the help last time), but I also want to unpivot Columns N-Q as well. Any help or suggestions will be greatly appreciated. Keep in mind I tried using the table function on here but it doesn't work very well for me due to the size of my data so apologies for the inconvenience. I will gladly upvote your responses if you help me.
Option Explicit
Sub TransformData()
' 1. Define constants (the arrays obviously aren't constants).
' s - source (read from)
' sd - source data (no headers)
' d - destination (write to)
' r - row
' c - column
' u - unpivot (columns)
' v - value (columns)
' Source
Const sName As String = "Sheet1"
' These columns will be unpivoted...
Dim suCols() As Variant: suCols = VBA.Array(8, 9, 10, 11)
' ... while these columns will be just copied except for the 0 column...
Dim svCols() As Variant: svCols = VBA.Array(12, 4, 0, 5, 6, 2, 3, 13, 14, 15, 16, 17)
' which is a 'place holder' for the pivot column.
' The 'svCols' array 'tells' that column 12 will be written to column 1,
' column 4 will be written to column 2, the unpivot columns will be written
' to column 3, ... etc.
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
Const duTitle As String = "Unit Name"
' 2. Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 3. Reference the source worksheet ('sws'), the source range ('srg')
' and the source data range ('sdrg'). Also, write the number of rows
' of each of the ranges to variables ('srCount', 'sdrCount')
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' has headers
Dim srCount As Long: srCount = srg.Rows.Count ' incl. headers
Dim sdrCount As Long: sdrCount = srCount - 1 ' excl. headers
Dim sdrg As Range: Set sdrg = srg.Resize(sdrCount).Offset(1) ' no headers
' 4. The Number of Destination Rows and Columns
' Determine the number of destination rows ('drCount').
Dim suUpper As Long: suUpper = UBound(suCols) ' represents the highest index number with suCols
Dim drCount As Long: drCount = 1 ' headers
Dim su As Long
For su = 0 To suUpper
drCount = drCount + sdrCount _
- Application.CountBlank(sdrg.Columns(suCols(su)))
Next su
' Determine the number of destination columns ('dcCount').
Dim svUpper As Long: svUpper = UBound(svCols)
Dim dcCount As Long: dcCount = svUpper + 1
' 5. The 2D One-Based Arrays
' Write the values from the source range to an array ('sData').
Dim sData As Variant: sData = srg.Value
' Define the destination array ('dData').
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' 6. Write the values from the source array to the destination array.
' Write headers.
Dim sValue As Variant
Dim sv As Long
For sv = 0 To svUpper
If svCols(sv) = 0 Then ' unpivot
sValue = duTitle
Else ' value
sValue = sData(1, svCols(sv))
End If
dData(1, sv + 1) = sValue
Next sv
' Write data.
Dim dr As Long: dr = 1 ' headers are already written
Dim sr As Long
For sr = 2 To srCount
For su = 0 To suUpper
sValue = sData(sr, suCols(su))
If Not IsEmpty(sValue) Then
dr = dr + 1
For sv = 0 To svUpper
If svCols(sv) = 0 Then ' unpivot
sValue = sData(sr, suCols(su))
Else ' value
sValue = sData(sr, svCols(sv))
End If
dData(dr, sv + 1) = sValue
Next sv
End If
Next su
Next sr
' 7. Write the results to the destination worksheet.
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Clear previous data.
dws.Cells.Clear
' Write the new values.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
' Write the values from the destination array
' to the destination worksheet.
.Resize(drCount).Value = dData
' Apply simple formatting:
' Headers.
.Font.Bold = True
' Entire Columns
.EntireColumn.AutoFit
End With
' Save the workbook.
'wb.Save
' 8. Inform to not wonder if the code has run or not.
MsgBox "Data transformed.", vbInformation
End Sub
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim hdr
Dim rgUnit As Range: Dim rgColor As Range: Dim cell As Range
Dim i As Long: Dim cnt As Long: Dim r As Long: Dim arr
'setting the sheet into variable - change if needed
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
'clear all cells in sh2
sh2.Cells.ClearContents
'the header which will be in sh2 coming from sh1 header as hdr variable
hdr = Array("Family", "Company Name", "Unit 1 name", "Unit 2 Name", "Unit 3 Name", "Unit 4 Name", "First Name", "Last Name", "Status", "Email", "Phone", "Color 1", "Color 2", "Color 3", "Color 4")
'put the data from sh1 to sh2 according to the header name defined in arr
For i = LBound(hdr) To UBound(hdr)
sh1.Columns(sh1.Rows(1).Find(hdr(i)).Column).Copy Destination:=sh2.Columns(i + 1)
Next
'start row
r = 2
Do
'set the range for Unit Name and Color according to the looped row into variable rgUnit and rgColor
Set rgUnit = sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))
Set rgColor = rgUnit.Offset(0, 9)
'count how many data in rgUnit as cnt variable
cnt = Application.CountA(rgUnit)
'if cnt > 1, copy the looped row then insert under it as many as cnt - 1
If cnt > 1 Then
sh2.Rows(r).Copy
sh2.Rows(r + 1 & ":" & r + cnt - 1).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
'fill the unit name
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgUnit.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
rgUnit.Resize(cnt, 1).Value = Application.Transpose(arr.keys)
'fill the color
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgColor.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
rgColor.Resize(cnt, 1).Value = Application.Transpose(arr.keys)
'increase the row value by add the cnt value
r = r + cnt
Loop Until Application.CountA(sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))) = 0 'finish the loop when rgUnit has no data
'delete unneeded column
rgUnit.Resize(rgUnit.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete
rgColor.Resize(rgColor.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete
'give the correct name for unit and color header in sh2
sh2.Range("C1").Value = "Unit Name"
sh2.Range("i1").Value = "Color"
End Sub
The sub assumed :
each person name at lease has one unit
if he has one unit name then he has one color , if he has two unit name then he has two colors, and so on.
each item in the hdr variable is exactly the same string which is in sheet1 header.
The process is explained in the commented line of the sub.
While in Sheet2, please step run the code and see what happen to the sheet when it step the line.
if the line Set arr = CreateObject("scripting.dictionary") throw you an error, please try the substitute code below:
'fill the unit name
Set rgFill = rgUnit.Resize(1, 1)
For Each cell In rgUnit.SpecialCells(xlCellTypeConstants)
rgFill.Value = cell.Value
Set rgFill = rgFill.Offset(1, 0)
Next
'fill the color
Set rgFill = rgColor.Resize(1, 1)
For Each cell In rgColor.SpecialCells(xlCellTypeConstants)
rgFill.Value = cell.Value
Set rgFill = rgFill.Offset(1, 0)
Next
And change the dim arr to dim rgFill as range

Pasting Data for samples based on their Test and ID

I have a data sheet with Sample IDs, Test type, and Test results all in three separate columns(A,B,C).
Some samples IDs are listed multiple times, as they all receive different tests.
The three columns of Sample IDs, Test Type, and Test Results are on Sheet 1.
I paste the Sample ID son sheet 2 (only one iteration of each) down column A, and the test types across Row 1.
How do I paste the individual test result data in the correct position on the sheet?
Example: Sample 1 is the Y value and Test-type 1 is the Y axis.
I need to copy the test results and paste them according to sample ID and test type on another sheet.
Every time this workbook is to be used, the sample IDs and test type will change.
This is the code to paste the Sample IDs down Column A on Sheet2 and Test Type across row 1 on sheet 2.
Sub Transpose1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wkb1 As Workbook
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Raw Data")
'Where the data is stored
Set sht2 = wkb1.Sheets("TestResultTable")
'This is where everything is to be pasted
sht2.Range("B2:Z4200").ClearContents
sht1.Range("A1:A4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"A1"), Unique:=True
'Sample IDs pasted with only one iteration of each sample
sht1.Range("B1:B4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"B2"), Unique:=True
'Test Type pasted on sheet2 to be copied again and pasted horizontally
sht2.Range("B3:B4200").Copy
sht2.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
sht2.Range("B2:B4200").ClearContents
'The Test results are in sht1 column C
End Sub
The results will not be this organized and A,B,C,D etc. This was to hide proprietary information.
Screenshot of example data and format
A Basic VBA Pivot
Sub BasicPivot()
' s - Source (read from)
Const sName As String = "Raw Data"
Const sFirstCellAddress As String = "A1"
Const srCol As Long = 1
Const scCol As Long = 2
Const svCol As Long = 3
' d - Destination (write to)
Const dName As String = "TestResultTable"
Const dFirstCellAddress As String = "A1"
Const dFirstColumnHeader As String = ""
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 1.) Write the source data to an array.
' a) Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' b) Reference the source range.
Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
' c.) Write the values from the source range to an array.
Dim sData As Variant: sData = srg.Value
' 2.) Use dictionaries to get the unique row and column labels.
' a) Define the row dictionary.
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1
' b) Define the column dictionary.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim dc As Long: dc = 1
' c) Loop through the rows of the array and write the unique
' row and column labels to the dictionaries.
Dim Key As Variant
Dim sr As Long
For sr = 2 To srCount
Key = sData(sr, srCol)
If Not rDict.Exists(Key) Then
dr = dr + 1
rDict(Key) = dr
End If
Key = sData(sr, scCol)
If Not cDict.Exists(Key) Then
dc = dc + 1
cDict(Key) = dc
End If
Next sr
' 3.) Write the result to an array.
' a) Define the array.
Dim drCount As Long: drCount = rDict.Count + 1
Dim dcCount As Long: dcCount = cDict.Count + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' b) Write the first column header.
Dim dfHeader As String
If Len(dFirstColumnHeader) = 0 Then
dfHeader = CStr(srg.Cells(1).Value)
Else
dfHeader = dFirstColumnHeader
End If
dData(1, 1) = dfHeader
' c) Write the row labels.
dr = 1
For Each Key In rDict.Keys
dr = dr + 1
dData(dr, 1) = Key
Next Key
' d) Write the column labels.
dc = 1
For Each Key In cDict.Keys
dc = dc + 1
dData(1, dc) = Key
Next Key
' e) Write the values.
For sr = 2 To srCount
dData(rDict(sData(sr, srCol)), cDict(sData(sr, scCol))) _
= sData(sr, svCol)
Next sr
' 4.) Write the results to the destination.
' a) Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' b) Clear its cells.
dws.UsedRange.Clear
' c) Write the values from the array to the destination range.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
.Resize(drCount).Value = dData
End With
' 5.) Inform.
MsgBox "Pivot has finished.", vbInformation
End Sub

Insert extra columns to match a fixed predefined header row

Problem- In an excel file which is received monthly, sometimes few columns are found missing due to manual input. So what is done currently to maintain consistency is that a fixed set of column headers is kept as the master set in an old separate worksheet and whenever the new file is received, headers of the new file and old master set are matched and whatever column is found missing in the received new file, a new column is inserted and the header name is placed from the master list, the column is left blank just with the header.
Example-
Master list of columns and headers- A B C D E F G H
New list of of column and headers- A B D F G H
So here column headers C,E are missing so we need to insert one columns after B and D and write headers also.
Current code-
Header_New = NewFile.Sheets(1).Rows(1).Value
Header_Old = OldFile.Sheets(1).Rows(10).Value
For Count = 1 to 100 ' let's assume there are 100 columns in Old
If Header_New(1, Count) <> Header_Old(1, Count) then
?? now what best to do to Header_New/NewFile??
End if
Next
Thank you for any help.
Update Columns
In the destination worksheet, will sort the columns in the order found in the source worksheet. Missing columns will be added only containing the respective header.
Option Explicit
Sub UpdateColumns()
Const sRow As Long = 10
Const dRow As Long = 1
Dim sws As Worksheet: Set sws = OldFile.Worksheets(1)
Dim slCell As Range
Set slCell = sws.Rows(sRow).Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then Exit Sub
Dim scCount As Long: scCount = slCell.Column
Dim srg As Range: Set srg = sws.Rows(sRow).Resize(, scCount)
Dim dws As Worksheet: Set dws = NewFile.Worksheets(1)
Application.ScreenUpdating = False
Dim sCell As Range
Dim sc As Long
Dim dIndex As Variant
Dim drg As Range
For sc = scCount To 1 Step -1
Set sCell = srg.Cells(sc)
Set drg = dws.Rows(dRow).Resize(, scCount * 2)
dIndex = Application.Match(sCell, drg, 0)
If IsNumeric(dIndex) Then
dws.Columns(dIndex).Cut
drg.Cells(1).EntireColumn.Insert Shift:=xlShiftToRight
Else
drg.Cells(1).EntireColumn.Insert Shift:=xlShiftToRight
drg.Cells(1).Offset(, -1).Value = sCell.Value
End If
Next sc
Application.ScreenUpdating = True
MsgBox "Columns updated.", vbInformation
End Sub

VBA to Delete Excel Columns from a List

I regularly download an excel file that has 1000+ columns, many of these are unwanted and manually deleting them is quite tedious. I found a VBA that will delete the unwanted columns but this method is not suited for a large list.
So, I have a workbook where Sheet1 is the data and columns run from A to BQM. I took all the header names and transposed them into column A in Sheet2 (A2:A1517). I think I'm looking for a way to have the vba look through the table in Sheet2 and delete any matching header titles on Sheet1. Any suggestions? I'm new at this so go slow.
Sub DeleteColumnByHeader()
Set P = Range("A2:BQM2")
For Each cell In P
If cell.Value = "MAP Price" Then cell.EntireColumn.Delete
If cell.Value = "Retail Price" Then cell.EntireColumn.Delete
If cell.Value = "Cost" Then cell.EntireColumn.Delete
If cell.Value = "Additional Specifications" Then cell.EntireColumn.Delete
Next
End Sub
EDIT2: actually works now...
EDIT: added re-positioning of matched columns
Using Match():
Sub DeleteAndSortColumnsByHeader()
Dim wsData As Worksheet, wsHeaders As Worksheet, mHdr, n As Long
Dim wb As Workbook, arr, rngTable As Range, addr
Dim nMoved As Long, nDeleted As Long, nMissing As Long
Set wb = ThisWorkbook 'for example
Set wsData = wb.Sheets("Products")
Set wsHeaders = wb.Sheets("Headers")
'get array of required headers
arr = wsHeaders.Range("A1:A" & _
wsHeaders.Cells(Rows.Count, "A").End(xlUp).Row).Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'shift the data over so we can move columns into the required order
Set rngTable = wsData.Range("a1").CurrentRegion 'original data
addr = rngTable.Address 'remember the position
rngTable.EntireColumn.Insert
Set rngTable = wsData.Range(addr) 'restore to position before insert
'loop over the headers array
For n = 1 To UBound(arr, 1)
mHdr = Application.Match(arr(n, 1), wsData.Rows(1), 0) 'current position of this header
If IsError(mHdr) Then
'required header does not exist - do nothing, or add a column with that header?
wsData.Cells(1, n).Value = arr(n, 1)
nMissing = nMissing + 1
Else
wsData.Columns(mHdr).Cut wsData.Cells(1, n) 'found: move
nMoved = nMoved + 1
End If
Next n
'delete everything not found and moved
With rngTable.Offset(0, rngTable.Columns.Count)
nDeleted = Application.CountA(.Rows(1)) 'count remaining headers
Debug.Print "Clearing: " & .Address
.EntireColumn.Delete
End With
Application.Calculation = xlCalculationAutomatic
Debug.Print "moved", nMoved
Debug.Print "missing", nMissing
Debug.Print "deleted", nDeleted
End Sub
In Sheet2 please clear the cells that display names of columns to delete.
And run the below code.
Sub DeleteColumnByHeader()
For Col = 1517 To 2 Step -1
If Range("Sheet2!A" & Col).Value == "" Then
Columns(Col).EntireColumn.Delete
End If
Next
End Sub
Delete Columns by Headers
The DeleteColumnsByHeaders procedure will do the job.
Adjust the values in the constants section.
The remaining two procedures are here for easy testing.
Testing
To test the procedure, add a new workbook and make sure it contains the worksheets Sheet1 and Sheet2.
Add a module and copy the complete code to it.
Run the PopulateSourceRowRange and the PopulateDestinationColumnRange procedures. Look at the worksheets to see the example setup.
Now run the DeleteColumnsByHeaders procedure. Look at the Destination Worksheet (Sheet1) and see what has happened: all the unwanted columns have been deleted leaving only the 'hundreds'.
Option Explicit
Sub DeleteColumnsByHeaders()
Const sName As String = "Sheet2"
Const sFirst As String = "A2"
Const dName As String = "Sheet1"
Const dhRow As String = "A2:BQM2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Column Range (unwanted headers).
Dim srg As Range
Dim srCount As Long
With wb.Worksheets(sName).Range(sFirst)
Dim slCell As Range
Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then Exit Sub
srCount = slCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write the values from the Source Range to the Source Data Array.
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
' Create a reference to the Destination Row Range.
Dim drg As Range: Set drg = wb.Worksheets(dName).Range(dhRow)
' Combine all cells containing unwanted headers into the Union Range.
Dim urg As Range
Dim dCell As Range
For Each dCell In drg.Cells
If IsNumeric(Application.Match(dCell, sData, 0)) Then
If urg Is Nothing Then
Set urg = dCell
Else
Set urg = Union(urg, dCell)
End If
End If
Next dCell
Application.ScreenUpdating = False
' Delete the entire columns of the Union Range.
If Not urg Is Nothing Then
urg.EntireColumn.Delete
End If
Application.ScreenUpdating = True
End Sub
' Source Worksheet ('Sheet1'):
' Writes the numbers from 1 to 1807 into the cells of the row range
' and to five rows below.
Sub PopulateSourceRowRange()
With ThisWorkbook.Worksheets("Sheet1").Range("A2:BQM2").Resize(6)
.Formula = "=COLUMN()"
.Value = .Value
End With
End Sub
' Destination Worksheet ('Sheet2'):
' Writes the numbers from 1 to 1807 except the hundreds (100, 200,... 1800)
' to the range 'A2:A1790'. The hundreds are the columns you want to keep.
Sub PopulateDestinationColumnRange()
Dim n As Long, r As Long
r = 1
With ThisWorkbook.Worksheets("Sheet2")
For n = 1 To 1807
If n Mod 100 > 0 Then
r = r + 1
.Cells(r, "A").Value = n
End If
Next n
End With
End Sub

Resources