ActiveSheet.Range("$A$1:$V$1023").AutoFilter Field:=4, Criteria1:= _
"cancelled"
ActiveSheet.Range("$A$1:$V$1023").AutoFilter Field:=5, Criteria1:="1"
Cells.Find(What:="cancelled", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 3) = "later"
Cells.Find(What:="cancelled", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, 3).Select
Selection.FillDown
Those are my code. Then I copy pasted it to another worksheet, and the change to "later" disappeared
Rows("1:1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Note that .FillDown Work with a range of cells and not a single cells.
This should work
Sub test()
Dim Foundcell As Range
Set Foundcell = Cells.Find(What:="cancelled", After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Offset(0, 3)
Foundcell.Value = "later"
Range(Foundcell.Address, "D" & ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row).FillDown
End Sub
Output (does this match to your needs) :
For the code you just added It is better to avoid select
Hope this helps, Waiting for your feedbacks
Related
I need to change the code so that
LMX220MA (KIT) becomes X220MA,
LMX220MA becomes X220MA,
LMX220 (KIT) becomes X220MB,
LMX220 becomes X220MB.
Tried removing LMX22 Selection.Replace line and then adding:
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],6)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
Selection.Replace What:="LMX220", Replacement:="X220MB", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],8)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks
Selection.Replace What:="LMX220MA", Replacement:="X220MA",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
and so on.
Original code:
' Insert Model Number_Carrier column
Sheets("Data_Upload").Select
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Select
ActiveCell.FormulaR1C1 = "Model Number_Carrier"
' Fill Model Number_Carrier field
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],5)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Replace What:="LMX21", Replacement:="X210MA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="MW41M", Replacement:="_", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Q710M", Replacement:="Q710MS", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMQ61", Replacement:="Q610MA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMQ71", Replacement:="_", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="X410M", Replacement:="X410MK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMX22", Replacement:="X220MB", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
It will fill ModelNumber_Carrier cells with what is in the cell in Model column (LMX220 becomes LMX220) and "ModelNumber_Carrier" column becomes "Model" even though ModelNumber_Carrier column coding was left alone.
Returning compile error: end sub error when I change it to this:
Sub MPCSWeeklyReturnReason()
'
' MPCS_Return_Reason Macro
'
' Prevents screen refreshing.
Application.ScreenUpdating = False
' Check if procedure has already run
Dim rCell As String
rCell = ActiveSheet.Range("H1").Text
If InStr(1, rCell, "Model Number_Carrier") Then
Application.ScreenUpdating = True
MsgBox "Macro already run."
Exit Sub
Else
' Combine all worksheets to one for upload
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Data_Upload"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
' Insert Model Number_Carrier column
Sheets("Data_Upload").Select
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Select
ActiveCell.FormulaR1C1 = "Model Number_Carrier"
' Fill Model Number_Carrier field
Sub FindReplaceAll()
' This will find and replace text in all sheets
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim fnd1 As Variant
Dim rplc1 As Variant
Dim fnd2 As Variant
Dim rplc2 As Variant
Dim fnd3 As Variant
Dim rplc3 As Variant
'Set the criteria to change here
fnd = "LMX220MA (KIT)"
rplc = "X220MA"
fnd1 = "LMX220MA"
rplc1 = "X220MA"
fnd2 = "LMX220 (KIT)"
rplc2 = "X220MB"
fnd3 = "LMX220"
rplc3 = "X220MB"
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd1, Replacement:=rplc1, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd2, Replacement:=rplc2, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd3, Replacement:=rplc3, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
' ESN Concantenate Fix
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=TEXT(,RC[-11])"
Selection.Copy
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 16).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("R2").Select
ActiveCell.FormulaR1C1 = "=IF(ISERROR(RC[-1]), RC[-12], RC[-1])"
Selection.Copy
Range("Q2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Q:R").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
' TRIM Reason and SUBReason spaces
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=TRIM(RC[-4])"
Selection.Copy
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 16).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
' Enables screen refreshing.
Application.ScreenUpdating = True
' Save the Workbook
ActiveWorkbook.Save
End If
End Sub
Here try this. It will go through all of the sheets in your workbook and find and replace all cases with the text you specified. I was unsure if you wanted to have the "(KIT)" included so I left it in, but feel free to adjust as necessary.
Sub FindReplaceAll()
' This will find and replace text in all sheets
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim fnd1 As Variant
Dim rplc1 As Variant
Dim fnd2 As Variant
Dim rplc2 As Variant
Dim fnd3 As Variant
Dim rplc3 As Variant
'Set the criteria to change here
fnd = "LMX220MA (KIT)"
rplc = "X220MA"
fnd1 = "LMX220MA"
rplc1 = "X220MA"
fnd2 = "LMX220 (KIT)"
rplc2 = "X220MB"
fnd3 = "LMX220"
rplc3 = "X220MB"
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd1, Replacement:=rplc1, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd2, Replacement:=rplc2, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd3, Replacement:=rplc3, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
Took another look at this and you can also do it this way by using arrays. Similar to my other answer with this one if I left in the "(KIT)" that shouldn't have been there or anything just adjust as necessary but the syntax is there.
Sub FindReplaceAll()
Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long
'Set the criteria to change here
fndList = Array("LMX220MA (KIT)", "LMX220MA", "LMX220 (KIT)", "LMX220")
rplcList = Array("X220MA", "X220MA", "X220MB", "X220MB")
'Loop through each item in Array lists
For x = LBound(fndList) To UBound(fndList)
'Loop through each worksheet in ActiveWorkbook
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Next x
End Sub
Column A to H has data with some blanks in between. I want to find "ABC" in column A and then select 2 rows above - this will be my ActiveCell.
I want to delete rows in between ActiveCell to Row2 (Active Cell is Dynamic)
Sub format()
Cells.Find(What:="abc", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:= xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate
ActiveCell.Offset(-2, 0).Select
Range(Selection, ActiveCell, A2).Select
End Sub
The code will do the job for you:
Sub format()
Dim rng As Range
Set rng = Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
rng.Offset(-2, 0).Select
Range(Cells(Selection.Row, 1), Cells(2, 1)).Select
'Selection.EntireRow.Delete
End Sub
Currently I have commented out the last line which will delete the Rows you want. uncomment it, but first be sure that's what you want to delete.
For Range please try:
(ActiveCell, "A2").Select
I am trying to find a value "PLGDY", copy data from this row, insert a new row above the one found, paste the data into new row, replace value "PLGDY" with "PLGDN".
I wrote a macro that instead of copying data into new row it pastes into cells to the right. It also changes values in both rows to "PLGDN".
I would like to use For Next loop, because I have plenty of values to change. Is it possible to check how many values to change? I would like to use this number as counter.
Sub Find_and_Change()
'
'Find a "PLGDY" and set an active cell
Cells.Find(What:="PLGDY", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'select a block of data in a row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
'copy selected block of data
Selection.Copy
'insert a row above active cell
ActiveSheet.Cells(ActiveCell.Row, 1).Select
ActiveCell.EntireRow.Insert
'set an active cell at the beginig of a row and move into column A
ActiveSheet.Cells(ActiveCell.Row, 1).Select
' paste copied data into this cell
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Now I select whole row
ActiveCell.EntireRow.Select
'I need to replace PLGDY with PLGDN in this row
Selection.Replace What:="PLGDY", Replacement:="PLGDN", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'I need to move active cell 10 columns right and one row down because I want to find next PLGDY
ActiveCell.Offset(1, 10).Select
End Sub
mrbungle's Answer is spot on! Works great.
For anyone finding this and intends to use this code to duplicate rows with multiple values, there is one tweak to be made.
I was able to copy/paste the loop and change the variables to suit, only exception was I needed to add ActiveCell.EntireRow.Selectafter the ActiveCell.EntireRow.Insert otherwise when the second loop came through with the new values it replaced the original value as well as the new row was not selected. Updated code for my purposes is:
Private Sub LT2V()
Dim vCount As Integer
'Add Lesser tier of 2V
vCount = Application.WorksheetFunction.CountIf(Range("D:D"), "2V")
Do Until vCount = 0
Cells.Find(What:="2V", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Copy
ActiveCell.EntireRow.Insert
ActiveCell.EntireRow.Select
Selection.Replace What:="2V", Replacement:="1V", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Offset(1, 10).Select
vCount = vCount - 1
Loop
End Sub
You being new I understand you might not know all the shortcuts and built in functions. I still learn new ones all the time. In this case I used the built in worksheet function CountIf to get the number of times the values appear. Then to loop through I like to use Do Until Loop and just subtract 1 through each loop until I reach 0.
Sub Find_and_Change()
vCount = Application.WorksheetFunction.CountIf(Range("A1:Z100"), "PLGDY")
Do Until vCount = 0
Cells.Find(What:="PLGDY", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Copy
ActiveCell.EntireRow.Insert
Selection.Replace What:="PLGDY", Replacement:="PLGDN", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Offset(1, 10).Select
vCount = vCount - 1
Loop
End Sub
I need to look for each row that has the phrase " Total" in it, insert rows above and below it, format other cells in and around that same row, remove the phrase " Total" from the cell, and repeat the process for all other rows in the report.
The macro I've developed, once it's found and replaced all of the instances of " Total", I get the Run-time error '91': Object variable or With block variable not set.
I would like to finish the loop without ending up with the error as this has to be executed on multiple sheets. Here is the meat of the code:
'EmployerSummariesAddedForRegionsOnTabs Macro
Dim FoundCell As Range, LastCell As Range
Dim FirstAddr As String
With Range("D3:D3000")
Range("D3").Select
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundCell = Range("D1:D3000").Find(What:=" Total", After:=LastCell, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
Do Until FoundCell Is Nothing
Set FoundCell = Range("D1:D3000").FindNext(After:=FoundCell)
COLUMNS("D:D").Select
Selection.Find(What:=" Total", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Replace What:="Total", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Activate
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
ActiveCell.Offset(3, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
.
.
.
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
Range("A1").Select
End Sub
There are two steps to creating an object variable. First you must declare the object variable.
this error occurs because you didn't set a object correctly it is quite the same as null refrence exception if you have programming experience.
I ran your code and it seems that it doesn't do anything at all! Not even an error! so I assume that your error must because of somewhere else in your code.
any way this lines replace any total in active worksheet with nothing:
Cells.Replace What:=" Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
So I have two excel documents.
One to take data from (RESULT.xlsm).
Another to insert data into (Summary.xls).
What I want is the adjacent cell values next to the hightlighted names to get inserted into Summary.xls under the respective columns. So I tried recording a macro but what happens is only the first record gets inserted.
Since only two links are allowed for me, i put it all in one picture:
http://i50.tinypic.com/9veihl.png
Note: There are multiple records in RESULT.xlsm and the screenshot shows just one.
I would like help on how I can extract data from all the set of records and insert in Summary.xlsx
Here's the recorded macro code:
Sub Summ()
Workbooks.Open Filename:="Summary.xlsx"
Windows.Arrange ArrangeStyle:=xlVertical
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Air System Name", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B10").Select
Selection.Copy
Windows("Summary.xlsx").Activate
Range("A5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Floor Area", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B14").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Total coil load", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("C5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Sensible coil load", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range("B28").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("D5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Max block L/s", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("E5").Select
ActiveSheet.Paste
Range("A6").Select
End Sub
I've also attached the excel files at mediafire:
Excel files
Please do help.
Thanks alot:)
So I looked up at alot of resources and tried to follow what #Tim Williams told me to and stumbled across this page (the last part): https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/column-sets-to-rows
They had a solution almost close to my problem, so I made a few modifications and I'm done:D
Note: This is within the same document, different sheets.
The code of it:
Dim LR As Long, NR As Long, Rw As Long
Dim wsData As Worksheet, wsOUT As Worksheet
Dim HdrCol As Range, Hdr As String, strRESET As String
Set wsData = Sheets("Sheet1") 'source data
Set wsOUT = Sheets("Sheet2") 'output sheet
strRESET = " Air System Name " 'this value will cause the record row to increment
LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
'end of incoming data
Set HdrCol = wsOUT.Range("1:1").Find(strRESET, _
LookIn:=xlValues, LookAt:=xlWhole) 'find the reset category column
If HdrCol Is Nothing Then
MsgBox "The key string '" & strRESET & _
"' could not be found on the output sheet."
Exit Sub
End If
NR = wsOUT.Cells(Rows.Count, HdrCol.Column) _
.End(xlUp).Row 'current output end of data
Set HdrCol = Nothing
On Error Resume Next
For Rw = 1 To LR
Hdr = wsData.Range("A" & Rw).Value
If (Hdr = " Air System Name ") Then
NR = NR + 1
End If
If Hdr <> "" Then
Set HdrCol = wsOUT.Range("1:1").Find(Hdr, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not HdrCol Is Nothing Then
wsOUT.Cells(NR, HdrCol.Column).Value _
= wsData.Range("B" & Rw).Value
Set HdrCol = Nothing
End If
End If
Next Rw
The only little problem is the space. In my excel document, my report has trailing and leading spaces, and this doesn't match with my sheet2 columns headers, I kind of temporarily fixed it, since I looked around and couldn't find a way to automatically trim all the space from the whole column.
So that's it:)