I have two sheets , Sheet1 and sheet2 .
Sheet 1 is my Source sheet and I am mentioning the item number in column A.
Sheet 2 is my destination sheet the contains the list of item number from the data base.
I am comparing the column A of source sheet with column E of my destination sheet, if they both have same item number then I am deleting the entire row.
I am using the below code for this. on 6 item number 4 are getting deleted and 2 are not getting deleted.
But, when I copy the same item number from the destination sheet to source sheet ,then it is getting deleted. I am not sure why this is happening. Could any one guide how I could figure this out.
below is the code
Sub spldel()
Dim srcLastRow As Long, destLastRow As Long
Dim srcWS As Worksheet, destWS As Worksheet
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set srcWS = ThisWorkbook.Sheets("sheet1")
Set destWS = ThisWorkbook.Sheets("sheet2")
srcLastRow = srcWS.Cells(srcWS.Rows.count, "A").End(xlUp).Row
destLastRow = destWS.Cells(destWS.Rows.count, "E").End(xlUp).Row
For i = 5 To destLastRow - 1
For j = 1 To srcLastRow
' compare column E of both the sheets
If destWS.Cells(i, "E").Value = srcWS.Cells(j, "A").Value Then
destWS.Cells(i, "E").EntireRow.delete
End If
Next j
Next i
End Sub
Remember to loop in reverse order when you are trying to delete the rows otherwise rows may skipped from deletion even when they qualify the deletion criteria.
So the two For loops should be like this....
For i = destLastRow - 1 To 5 Step -1
For j = srcLastRow To 1 Step -1
Here is another approach:
Rather than looping through each item everytime in your source and destination sheets, just use MATCH function:
Function testThis()
Dim destWS As Worksheet: Set destWS = ThisWorkbook.Worksheets("Sheet8") ' Change to your source sheet
Dim srcWS As Worksheet: Set srcWS = ThisWorkbook.Worksheets("Sheet12") ' Change to your destination sheet
Dim iLR As Long: iLR = srcWS.Range("L" & srcWS.Rows.count).End(xlUp).Row ' Make sure you change the column to get the last row from
Dim iC As Long
Dim lRetVal As Long
On Error Resume Next
For iC = 1 To iLR
lRetVal = Application.WorksheetFunction.Match(srcWS.Range("L" & iC), destWS.Range("A:A"), 0)
If Err.Number = 0 Then
destWS.Range("A" & lRetVal).EntireRow.Delete
End If
Err.Clear
Next
On Error GoTo 0
End Function
Related
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I have a summary sheet Consolidated Tracker and data sheets that won't be set statically as they'll be dates i.e Sheet1 renamed May 2018 Sheet2 renamed October 2018 Sheet3 renamed May 2019 etc.
The follow code checks for a match in Column B across two statically set worksheets Consolidated Tracker and May 2018.
If a match is found, it takes the value from cell C4 in May 2018 and sets C4 in the Consolidated Tracker to this value.
What I'd next like to achieve is to check:
Sheet3 and Set D4 in the Consolidated Tracker if a match is found.
Sheet4 and set E4 in the Consolidated Tracker if a match is found.
Sheet5 and set F4 in the Consolidated Tracker if a match is found.
I've got this far by myself but I'm unsure how to procede from here.
Thank you.
Option Explicit
Public Sub UpdateData()
Dim WsDest As Worksheet 'destination workbook to write in
Set WsDest = ThisWorkbook.Worksheets("Consolidated Tracker")
Dim WsSrc As Worksheet 'source workbook to match with
Set WsSrc = ThisWorkbook.Worksheets("May 2018")
Dim LastRow As Long 'last used row in workbook
LastRow = WsDest.Cells(WsDest.Rows.Count, "B").End(xlUp).Row
Dim iRow As Long, MatchedRow As Long
For iRow = 1 To LastRow 'loop through all rows from row 1 to last used row and update each row
MatchedRow = 0 'initialize
On Error Resume Next 'if no match found then ignore error
MatchedRow = WorksheetFunction.Match(WsDest.Cells(iRow, "B"), WsSrc.Columns("B"), 0) 'get the row number of the match
On Error GoTo 0 'reactivate error reporting
If MatchedRow > 0 Then 'if a match was found then copy values
WsDest.Cells(iRow, "C").Value = WsSrc.Cells(MatchedRow, "C").Value
End If
Next iRow
End Sub
Does this do what you want?
It uses the sheet index but I'm uneasy about that because sheets can easily be re-ordered and your code will blow up.
As it stands the code will run through from the first to penultimate sheet (assuming your destination sheet is last) so you might need to adjust the j loop.
Public Sub UpdateData()
Dim WsDest As Worksheet 'destination workbook to write in
Set WsDest = ThisWorkbook.Worksheets("Consolidated Tracker")
Dim LastRow As Long 'last used row in workbook
LastRow = WsDest.Cells(WsDest.Rows.Count, "B").End(xlUp).Row
Dim iRow As Long, MatchedRow As Variant, j As Long, c As Long
c = 3
For j = 1 To Sheets.Count - 1
For iRow = 1 To LastRow 'loop through all rows from row 1 to last used row and update each row
MatchedRow = Application.Match(WsDest.Cells(iRow, "B"), Worksheets(j).Columns("B"), 0) 'get the row number of the match
If IsNumeric(MatchedRow) Then 'if a match was found then copy values
WsDest.Cells(iRow, c).Value = Worksheets(j).Cells(MatchedRow, "C").Value
End If
Next iRow
c = c + 1
Next j
End Sub
Here is a better method which doesn't rely on sheet indexes.
Public Sub UpdateData()
Dim WsDest As Worksheet 'destination workbook to write in
Set WsDest = ThisWorkbook.Worksheets("Consolidated Tracker")
Dim LastRow As Long 'last used row in workbook
LastRow = WsDest.Cells(WsDest.Rows.Count, "B").End(xlUp).Row
Dim iRow As Long, MatchedRow As Variant, c As Long, ws As Long
c = 3
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> WsDest.Name Then
For iRow = 1 To LastRow 'loop through all rows from row 1 to last used row and update each row
MatchedRow = Application.Match(WsDest.Cells(iRow, "B"), ws.Columns("B"), 0) 'get the row number of the match
If IsNumeric(MatchedRow) Then 'if a match was found then copy values
WsDest.Cells(iRow, c).Value = ws.Cells(MatchedRow, "C").Value
End If
Next iRow
c = c + 1
End If
Next ws
End Sub
Could someone help with this code?
I'm comparing two workbooks. I've built a For loop to check to see if the unique ids in workbook1 match the ids in workbook2.
If they match I'm assigning the returned row # to variable lrow. I then need to check the value in column C for the returned row.
Depending on the value in lrow, column C I need to cut the row in workbook1, sheet1 and paste to different sheets in workbook1. I also
need to delete the row that was cut so I dont have blank rows when done.
I'm getting a syntax error on the nested Else If statements. They are all highlighted in red. I'm also getting a Compile error on
these lines that says "Must be first statement on the line".
Could you let me know what I'm missing with the nested if and also verify if my cut and paste operation is valid.
Thanks for your assistance.
Option Explicit
Sub Complete()
Dim Lastrow, Newrow As Long
Dim i, lrow As Long
Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
' Turn off notifications
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("workbook2.xlsx")
Set ws1 = wb1.Worksheets("Sheet1")
Set ws2 = wb2.Worksheets("Sheet1")
With wb1.Worksheets(ws1)
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
lrow = Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)
If ws2.Cells(lrow,"C") = 18 Then
Newrow = wb1.Worksheets("Sheet3").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet3").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 23 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 24 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 36 Then
Newrow = wb1.Worksheets("Sheet5").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet5").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
End If
End If
Next i
End With
Workbooks("workbook2.xlsx").Close savechanges:=False
' Turn on notifications
Application.ScreenUpdating = True
' Message Box showing that process is complete.
MsgBox "Done!"
End Sub
From the last comment I made to #paulbica I corrected the line to read:
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
The code now runs correctly. I've update the post to reflect the changes made.
Thanks.
It's good that you solved the Type mismatch error, but there are a couple of issues left
The line With wb1.Worksheets(ws1) will throw another Type mismatch error because the Worksheets function takes the sheet name or index as an argument and ws1 is a Worksheet object, so it should be changed to With wb1.Worksheets(ws1.Name) or simply With ws1
The loop implemented like that will skip rows if they are contiguous. For example, if you start with a total of 5 rows, all of which need to be moved, in the first iteration i is 2 and row 2 will be deleted. Next iteration row 3 had become row 2 after deletion, but i is now 3, so the initial row 3 is skipped and processing moves to current row 3 which previously was 4
Depending on how much data you have your code is quite slow because it interacts with the ranges very often. For example it's extracting the value of ws2.Cells(lrow,"C") for every If branch, extracting the last row in sheets 3, 4, and 5 for every cut operation, and deleting rows one at the time
This is how I'd write the code:
Option Explicit
Public Sub Complete()
Dim i As Long, toDel As Range, copyCell As Range
Dim ws11 As Worksheet, ws13 As Worksheet, ws14 As Worksheet, ws15 As Worksheet
Dim ws13LR As Long, ws14LR As Long, ws15LR As Long
Dim wb2 As Workbook, ws21 As Worksheet, wb2row As Variant, wb2colA As Variant
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb2 = Workbooks("workbook2.xlsx")
Set ws11 = Sheet1
Set ws13 = Sheet3: ws13LR = ws13.Cells(ws13.Rows.Count, 1).End(xlUp).Row + 1
Set ws14 = Sheet4: ws14LR = ws14.Cells(ws14.Rows.Count, 1).End(xlUp).Row + 1
Set ws15 = Sheet5: ws15LR = ws15.Cells(ws15.Rows.Count, 1).End(xlUp).Row + 1
Set ws21 = wb2.Sheets(1): wb2colA = ws21.UsedRange.Columns("A").Value2
For i = 2 To ws11.Cells(ws11.Rows.Count, 1).End(xlUp).Row + 1
wb2row = Application.Match(ws11.UsedRange.Cells(i, "G").Value, wb2colA, 0)
If Not IsError(wb2row) Then
Set copyCell = Nothing
Select Case ws21.Cells(wb2row, "C").Value2
Case 18: Set copyCell = ws13.Cells(ws13LR, "A"): ws13LR = ws13LR + 1
Case 23, 24: Set copyCell = ws14.Cells(ws14LR, "A"): ws14LR = ws14LR + 1
Case 36: Set copyCell = ws15.Cells(ws15LR, "A"): ws15LR = ws15LR + 1
End Select
If Not copyCell Is Nothing Then
With ws11.UsedRange
.Rows(i).EntireRow.Copy copyCell
If toDel Is Nothing Then
Set toDel = .Rows(i)
Else
Set toDel = Union(toDel, .Rows(i))
End If
End With
End If
End If
Next i
wb2.Close False
toDel.EntireRow.Delete
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I moved all unnecessary operations out of the For loop, and created a new range of rows to be deleted at the end, in one operation
Here is a bit of background on what I'm trying to achieve.
I have 2 excel files (Old and New), which contains around 10-15 sheets and each of the sheets contain many rows of data and total number of columns in each sheet is different.
I have reviewed Old file and placed my comments for all the rows in the last column of data in each sheet.
Now whenever I receive a New file, I need to first compare the Sheet name, if matches compare the Row of that sheet to old one if found copy the comment from last column of Old sheet to new one.
In short it's kind of reconciliation sheet.I have tried the following code but not getting how to loop for comparison of Workbook and then rows.
Sub recon()
Dim wb As Workbook
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim rnge As Range
Set wb = Workbooks("OldWB")
For Each sht In wb.Sheets
On Error Resume Next
Set sht2 = ActiveWorkbook.Sheets(sht.Name)
On Error GoTo 0
If Not sht2 Is Nothing Then
For Each rnge In sht.UsedRange
If sht2.Range(rnge.Address).Value = "" And rnge.Value <> "" Then
Copy sht2.Range(rnge.Address).Offset(0,1).Value = rnge.Value
End If
Next rnge
Set sht2 = Nothing
End If
Next sht
Set wb = Nothing
End Sub
Consider following points:
1. This code will give you desired result if sheets in both the workbook are in same order.
2. I am counting number of columns for each row assuming that the number of columns may vary row to row in each sheet. If this is not the case you can assign values to lastColumnCurr and lastColumnOld at the beginning of For Each loop.
Sub recon()
Dim wbOld As Workbook
Dim wsOld As Worksheet, wsCurr As Worksheet
Dim lastRowCurr As Long, lastRowOld As Long, lastColumnCurr As Long, lastColumnOld As Long
Dim i As Long, j As Long
Dim flag As Boolean
Set wbOld = Workbooks("old_test")
For Each wsOld In wbOld.Sheets
lastRowOld = wsOld.Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Set wsCurr = ActiveWorkbook.Sheets(wsOld.Name)
On Error GoTo 0
If Not wsCurr Is Nothing Then
'get number of rows in current sheet
lastRowCurr = wsCurr.Cells(Rows.Count, "A").End(xlUp).Row
'loop through all the rows
For i = 1 To lastRowCurr
'get number of columns in old and current sheets
lastColumnOld = wsOld.Cells(i, Columns.Count).End(xlToLeft).Column
lastColumnCurr = wsCurr.Cells(i, Columns.Count).End(xlToLeft).Column
'maintain a boolean to check whether all the values in a row are same or not
flag = True
'now loop through all the columns in a row
'here if the row in current sheet is same as the old sheet then there will be one column...
'...less in current sheetin compared to old sheet because of your comment column at the end...
'...hence lastColumnOld - 1
If lastColumnCurr = lastColumnOld - 1 Then
For j = 1 To lastColumnCurr
'now all the cells in a row in both sheets
If wsOld.Cells(i, j).Value <> wsCurr.Cells(i, j).Value Then
'if cell is not same, change boolean to false
flag = False
Exit For
End If
Next j
'if boolean is false then there is difference in rows so do not add comment at the end
If flag = True Then
wsCurr.Cells(i, j).Value = wsOld.Cells(i, j).Value
End If
End If
Next i
Set wsCurr = Nothing
End If
Next wsOld
Set wb = Nothing
End Sub
EDIT# 1
_________________________________________________________________________________
Following code will match each row of active sheet to all rows of the sheet in old workbook.
Sub CompareRows_Mrig()
Dim wbOld As Workbook
Dim wsOld As Worksheet, wsCurr As Worksheet
Dim lastRowCurr As Long, lastRowOld As Long, lastColumnCurr As Long, lastColumnOld As Long
Dim flag As Boolean
Set wbOld = Workbooks("old_test")
For Each wsOld In wbOld.Sheets
lastRowOld = wsOld.Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Set wsCurr = ActiveWorkbook.Sheets(wsOld.Name)
On Error GoTo 0
If Not wsCurr Is Nothing Then
lastRowCurr = wsCurr.Cells(Rows.Count, "A").End(xlUp).Row
Dim c As Long
Dim rIdx As Long, cIdx As Long
For rIdx = 1 To lastRowCurr
lastColumnCurr = wsCurr.Cells(rIdx, Columns.Count).End(xlToLeft).Column
c = 0
For rIdx2 = 1 To lastRowOld
lastColumnOld = wsOld.Cells(rIdx2, Columns.Count).End(xlToLeft).Column - 1
If lastColumnCurr = lastColumnOld Then
flag = True
For cIdx = 1 To lastColumnCurr
If wsCurr.Cells(rIdx, cIdx).Value <> wsOld.Cells(rIdx2, cIdx).Value Then
flag = False
Exit For
End If
Next
c = c + 1
Debug.Print c
If flag = True Then
wsCurr.Cells(rIdx, cIdx).Value = wsOld.Cells(rIdx2, cIdx).Value
End If
End If
Next
Next
End If
Next wsOld
Set wb = Nothing
End Sub
EDIT# 2
_________________________________________________________________________________
To Speed up the code add following lines in sub:
Sub CompareRows_Mrig()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'*****************************
'Put Code Here
'*****************************
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have two workbooks , one is a active list(database) and the other is a project tracker(dashboard).
Both workbooks have a project ID.
I want that the workbook and active list should have a loop to match the exact project IDs.
If the project ID is found in the active list, it would retrieve information from that row and overwrite the existing row in the project tracker,which contains that project ID.
This is an example of the code which i have done, I did something relevant but it does not seem to work :
Sub AAA()
'If Workbooks("Source.xlsm").Sheets("Sheet2").Range("A2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("A2").Value Then
'Workbooks("Source.xlsm").Sheets("Sheet2").Range("B2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("C2").Value
Dim a As Long
Dim lastrow As Long
Dim lastcol As Long
Dim source As Worksheet
Dim target As Worksheet
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
lastrow = source.Range("A" & target.Rows.Count).End(xlUp).Row
lastcol = target.Cells(2, target.Columns.Count).Column
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).Select
Range(ActiveCell, ActiveCell.Offset(0)).Copy
source.Range("B" & a).PasteSpecial
End If
Next a
End Sub
You are misunderstanding how you use the Range object. This .Range("A").Value does not work, you need to include a row number as well, such as .Range("A1").Value.
Your logic assumes that both lists are in exactly the same order. Using the Range.Find method gets round that problem.
Sub AAA()
Dim source As Worksheet
Dim target As Worksheet
Dim cell As Range
Dim cellFound As Range
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
For Each cell In target.Range("A2:A50")
' Try to find this value in the source sheet
Set cellFound = source.Range("A:A").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellFound Is Nothing Then
' A matching value was found
' So copy the cell 2 columns across to the cell adjacent to matching value
' Do a "normal" copy & paste
cell.Offset(ColumnOffset:=2).Copy cellFound.Offset(ColumnOffset:=1)
' Or do a copy & paste special values
'cell.Offset(ColumnOffset:=2).Copy
'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues
Else
' The value in this cell does not exist in the source
' Should anything be done?
End If
Next
End Sub
Are you aware that you are using different sheets for source and for target?
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).EntireRow.Select
Selection.Copy
source.Range("B" & a).PasteSpecial
End If
Next a
Not sure what volume of data you're going to be working with, but you could also use arrays to achieve what you're after.
Option Explicit
Sub AAA()
Dim i As Long, j As Long, k As Integer
Dim source As Worksheet, target As Worksheet
Dim arrTarget() As Variant, arrSource() As Variant
Dim lrowSrc As Long, lcolSrc As Long, lrowTrgt As Long, lcolTrgt As Long
Set target = Workbooks("Book4.xlsb").Sheets("Sheet1")
Set source = Workbooks("Book3.xlsb").Sheets("Sheet1")
lrowSrc = source.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolSrc = source.Cells(2, source.Columns.Count).End(xlToLeft).Column
lrowTrgt = target.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolTrgt = target.Cells(2, target.Columns.Count).End(xlToLeft).Column
target.Activate
arrTarget = target.Range(Cells(2, 1), Cells(lrowTrgt, lcolSrc))
source.Activate
arrSource = source.Range(Cells(2, 1), Cells(lrowSrc, lcolSrc))
target.Activate
For i = LBound(arrTarget, 1) To UBound(arrTarget, 1)
For j = LBound(arrSource, 1) To UBound(arrSource, 1)
If arrTarget(i, 1) = arrSource(j, 1) Then
For k = LBound(arrSource, 2) To UBound(arrSource, 2)
arrTarget(i, k) = arrSource(j, k)
Next k
Exit For
End If
Next j
Next i
target.Range("A2").Resize(UBound(arrTarget, 1), UBound(arrTarget, 2)).Value = arrTarget
End Sub
Working on 12,000 rows of data in the Target workbook and 25,000 in the Source workbook, with 6,000 matches, the code took 9.91 seconds to run.
Here is the Macro I've just written out, unfortunately it doesn't seem to do anything and I can't find the error! I am trying to copy the column with the header "Offset Acct" from sheet 1 (SAPDump) to sheet 2 (Extract) which is blank. Can anyone see explain to me why this isn't working? Fairly new to VBA so it's probably an easy fix. Cheers
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
' Define row and column counters
Dim r As Long
Dim c As Long
' Set last non-empty column
Dim lastCol As Long
lastCol = SAPDump.Cells(1, Columns.Count).End(xlToLeft).Column
' Set last non-empty row
Dim lastRow As Long
lastRow = SAPDump.Cells(Rows.Count, "A").End(xlUp).row
' Look a all columns
For c = 1 To c = lastCol
' Examine top column
If SAPDump.Cells(1, c).Value = "Offset Acct" Then
' Loop round all rows
For r = 1 To r = lastRow
' Copy column into A on Extract
Extract.Cells(r, 1) = SAPDump.Cells(r, c)
Next r
Else
End If
Next c
End Sub
You need to change these lines:
For c = 1 To c = lastCol
to
For c = 1 To lastCol
and
For r = 1 To r = lastRow
to
For r = 1 To lastRow
Edit:
A better way may be to do this:
Sub ExtractData()
' Define sheets
Dim SAPDump As Worksheet
Dim Extract As Worksheet
'Define Heading range
Dim rHeadings As Range
Dim rCell As Range
' Set sheets
Set SAPDump = ActiveSheet
Set Extract = ThisWorkbook.Sheets("Extract")
'Set Heading range.
With SAPDump
Set rHeadings = .Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))
End With
'Look at each heading.
For Each rCell In rHeadings
If rCell.Value = "Offset Acct" Then
'If found copy the entire column and exit the loop.
rCell.EntireColumn.Copy Extract.Cells(1, 1)
Exit For
End If
Next rCell
End Sub
The set is not sure, how to run the same within excel macro.
Request you to send the same via .pdf formate.
Regards
Stalin.