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
Related
I'm trying to check a range of cells for the value "X" and when the column name where the "X" was found is among an array I have previously specified, I want to have a helper column that would say TRUE otherwise say FALSE.
To illustrate, here's a sample table:
In my sample, I have this array that contains 3 values ( Math, English and History). If there is an X in any of the rows whose header name is in the array, I want the helper column to say TRUE otherwise FALSE. It doesn't have to be all of the values in the array, it can be at least only one.
Here is my code (my original file has more columns than my sample, so my code is liek this)
Sub add_helper()
' Adding helper column
Dim checking As Variant
checking = check_issue() -- this is another function, basically checking will contain the values I want to check in this case Math, English and History, i have confirmed this gets it successfully
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "I").End(xlUp).row
Set rowRange = wks.Range("I2:AD" & LastRow)
Set colRange = wks.Range("I1:AD1")
'Loop through each row
For Each rrow In rowRange
Do
For Each cell In colRange
'Do something to each cell
If InStr(checking, cell.value) > 0 Then
If Cells(rrow.row, rrow.Column).value <> "" Then
wks.Range("AI" & rrow.row).value = "TRUE"
Exit For
Else
wks.Range("AI" & rrow.row).value = "FALSE"
End If
End If
Next cell
Loop Until wks.Range("AI" & rrow.row).value <> "TRUE"
Next rrow
End Sub
My code results to just having an input of true whenever there is an X without actually checking if the header column is in my array.
Did you try normal formulas in Excel? You could create a table (a ListObject) with the courses as your array values and the combine SUMPRODUCT with COUNTIF to output True/False in your helper column. Easy to update and adapt:
Notice the table at most right named T_COURSES. The formula in helper column is:
=SUMPRODUCT(--(COUNTIF(T_COURSES,$B$1:$E$1)>0)*--(B2:E2="x"))>0
It works perfectly and it autoupdates changing values:
Match Headers of Matches Against Values in Array
Option Explicit
Sub AddHelper()
Dim checking As Variant: checking = check_issue()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim hrg As Range: Set hrg = ws.Range("I1:AD1") ' Header Range
Dim drg As Range ' Data Range
Set drg = ws.Range("I2:AD" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row)
Dim crg As Range: Set crg = drg.EntireRow.Columns("AI") ' (Helper) Column Range
crg.Value = False
Dim rrg As Range, rCell As Range, r As Long, c As Long, IsFound As Boolean
For Each rrg In drg.Rows
r = r + 1 ' for the (helper) column range
c = 0 ' for the header range
For Each rCell In rrg.Cells
c = c + 1
If StrComp(CStr(rCell.Value), "x", vbTextCompare) = 0 Then
If IsNumeric(Application.Match(CStr(hrg.Cells(c)), checking, 0)) _
Then IsFound = True: Exit For
End If
Next rCell
If IsFound Then crg.Cells(r).Value = True: IsFound = False
Next rrg
End Sub
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
I've been tooling with this code originally provided by #Tim Williams.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Variant, cDest As Range, c As Range
Set wb = Workbooks("1")
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).row).Cells
m = Application.Match(c.Value, wsB.Columns("D"), 0) 'Match is faster than Find
If Not IsError(m) Then 'got a match?
wsB.Rows(m).Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
End If
Next c
End Sub
It searches through all the values in a column in Sheet A, finds those matching cells in a column of Sheet B, and finally copies that entire row to Sheet C.
It's working great, but I cant crack how to handle certain cases of duplicates.
If Sheet A has duplicates (ie. one cell contains "test" and the following cell contains "test"). It works great if Sheet B only has one cell that contains "test", as it copies this value over the the new sheet twice.
However, In Sheet B, if the cell containing 'test' is followed by another cell containing 'test', it only copies over the first one, not the one below it as well.
I'm having a hard enough time wrapping my head around even the logic of this, thanks for any input.
You would want to put a second loop inside the first loop, and create something with the logic "For Each Match that I find for this c.Value in Sheet B Column D... Do that copy paste code block"
To find multiple matches of the same value, you can use a FindNext loop. I am not familiar with the Match function and I don't know if its loopable.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
Next c
End Sub
So that above code will handle duplicates on Sheet B, but what to do if there are duplicates on sheet A? I suggest using a dictionary to keep track of c.Value and if it detects a duplicate, skips it.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Dim cVals As Object
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cVals = CreateObject("Scripting.Dictionary")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
If Not cVals.exists(c.Value) Then
cVals.Add c.Value, 0
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
End If
Next c
End Sub
You can see above, each loop checks to see if dictionary cVals already has the current value in the dictionary, and only continues with the code if it doesn't, otherwise moving to the next loop iteration.
A VBA Lookup: Lookup Direction
A Rule of Thumb
When there are two columns, you can lookup in two directions.
If you will be copying all the matches in column B, you should loop through the cells in column B and find matches in column A (see A Quick Fix).
Note that you could write all the unique values from column A to an array of strings and use it as the parameter of the Criteria1 argument of the AutoFilter method to filter the data in column B and copy it in one go. But we're playing around here, aren't we?
If the order of the values in column A matters, and there are duplicates in column B then you cannot easily use Application.Match but you could use a combination of the Find and FindNext methods.
I Wonder...
Why should it copy a found row twice ("It works great..., as it copies this value over to the new sheet twice")?
A Quick Fix
Option Explicit
Sub CopyMatches()
Dim wb As Workbook: Set wb = Workbooks("1")
Dim lws As Worksheet: Set lws = wb.Worksheets("A")
Dim sws As Worksheet: Set sws = wb.Worksheets("B")
Dim dws As Worksheet: Set dws = wb.Worksheets("C")
Dim lrg As Range ' Lookup
Set lrg = lws.Range("A2:A" & lws.Cells(lws.Rows.Count, "A").End(xlUp).Row)
Dim srg As Range ' Source
Set srg = sws.Range("D2:D" & sws.Cells(sws.Rows.Count, "D").End(xlUp).Row)
Dim dCell As Range ' Destination
Set dCell = dws.Range("A2") ' needs to be column 'A' because 'EntireRow'
'dCell.EntireRow.Offset(dws.Rows.Count - dCell.Row + 1).Clear
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(Application.Match(sCell, lrg, 0)) Then
sCell.EntireRow.Copy dCell
Set dCell = dCell.Offset(1)
End If
Next sCell
MsgBox "Data copied.", vbInformation
End Sub
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
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