Convert MMM-DD-YYYY text to date - excel

I have a set of data which only pulls as MMM-DD-YYYY. I'd like to convert it to a date (MM/DD/YYYY format) to look it up versus another set of data.
I recorded a macro to simply replace the months with their respective numbers individually but I know there has to be a better way to do this. Below is my
current code:
With ws1.Cells
.Replace What:="jan-", Replacement:="01-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="feb-", Replacement:="02-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="mar-", Replacement:="03-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="apr-", Replacement:="04-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="may-", Replacement:="05-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="jun-", Replacement:="06-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="jul-", Replacement:="07-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="aug-", Replacement:="08-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="sep-", Replacement:="09-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="oct-", Replacement:="10-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="nov-", Replacement:="11-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.Replace What:="dec-", Replacement:="12-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With

This will convert your text string into a true date for the active cell:
Sub datefix()
Dim s As String
s = ActiveCell.Value
arr = Split(s, "-")
ActiveCell.Value = arr(1) & " " & arr(0) & " " & arr(2)
End Sub
You can format it or loop it to your heart's content.
(I am using US locale)
EDIT#1:
With your desired format:
Sub datefix()
Dim s As String
s = ActiveCell.Value
arr = Split(s, "-")
ActiveCell.Value = arr(1) & " " & arr(0) & " " & arr(2)
ActiveCell.NumberFormat = "mm/dd/yyyy"
End Sub
Before:
and after:

Related

Why doesn't my VBA code work when the selection starts with a dot?

I've created this code that is supposed to replace the commas in a selection with dots if there are any. The code, however, doesn't work if the selection starts a cell containing a dot, but it works if it starts with a cell containing a comma. It even works if it starts with a comma, then a cell with a dot and then again a cell with a comma. Here is the code:
Public Sub DeleteDotsReplaceCommasWithDots()
For Each cell In Selection
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
If InStr(ActiveCell.Value, ".") > 0 And InStr(ActiveCell.Value, ",") > 0 Then
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
ElseIf InStr(ActiveCell.Value, ".") = 0 And InStr(ActiveCell.Value, ",") > 0 Then
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormul
End If
Next cell
End Sub
Any idea about why this is happening? Thanks :)
You seem to be running your search/replace on ActiveCell, rather than each cell you're cycling through with your For..Each loop. I've tidied it up slightly using the With cell.. End With block.
Try this:
Public Sub DeleteDotsReplaceCommasWithDots()
For Each cell In Selection
With cell
.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
If InStr(.Value, ".") > 0 And InStr(.Value, ",") > 0 Then
.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
ElseIf InStr(.Value, ".") = 0 And InStr(.Value, ",") > 0 Then
.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula
End If
End With
Next cell
End Sub

How to identify ≥ or ≤ in Excel VBA

This is probably a simple question but I just can't figure it out.
I've built a macro to convert values in Celsius to Fahrenheit in a range. The problem is, sometimes these comes with > or < than, and sometimes with ≥ or ≤ signs. I can not figure out a way to get VBA to recognize the ≥ or ≤ signs at all. I've tried ASCII and unicode and neither seems to be working.
I've included the code here (With my attempts at Unicode in place of the ≥ or ≤ symbols)
As it stands, it just replaces those symbols with nothing at all instead of putting them back into place.
Sub Celsius_to_Fahrenheit()
Set myRange = Selection
For Each myCell In myRange
LastString = ""
GTLT = ""
For i = 1 To Len(myCell.Value)
mt = Mid(myCell.Value, i, 1)
If mt Like "[0-9]" Or mt Like "-" Or mt Like "." Then
tstring = mt
ElseIf mt Like "–" Or mt Like "—" Then
tstring = "-"
ElseIf mt Like ">" Or mt Like "<" Or mt Like ChrW(U + 2264) Or mt Like ChrW(U + 2265) Then
GTLT = mt
tstring = ""
Else
tstring = ""
End If
LastString = LastString & tstring
Next i
myCell.Value = GTLT & 32 + (9 / 5) * LastString & " °F"
Next
Selection.Replace What:="-", Replacement:="–", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="111111111111", Replacement:="1", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="222222222222", Replacement:="2", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="333333333333", Replacement:="3", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="444444444444", Replacement:="4", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="555555555555", Replacement:="5", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="666666666666", Replacement:="6", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="777777777777", Replacement:="7", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="888888888888", Replacement:="8", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="999999999999", Replacement:="9", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="° °", Replacement:=" °", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

VBA code to find and replace using maybe wildcard?

How can I find and remove X from strings, in other words, replace NX1 with N1, NX2 with N2, NX7535 with N7535, all strings start with N but not all have X after N, if they do I need to remove that X, Below I put crazy code I adapted from excel recording but it has to be easier way to do it:
Sub Find_NX_Replace()
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="NX1", Replacement:="N1", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX2", Replacement:="N2", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX3", Replacement:="N3", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX4", Replacement:="N4", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX5", Replacement:="N5", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX6", Replacement:="N6", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX7", Replacement:="N7", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX8", Replacement:="N8", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="NX9", Replacement:="N9", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Example:
Do a loop of the number:
Sub Find_NX_Replace()
Dim i as Long
For i = 1 To 9
Selection.Replace What:="NX" & i, Replacement:="N" & i, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next i
End Sub

VBA Replace not working with numbers format

I am, once again, stuck on something.
I am trying to clean phone numbers data, and the code isn't doing anything.
Columns(icount).Replace What:=",", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns(icount).Replace What:="-", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
icount is the column where the phone # are.
I don't understand why it's not working. Replacing "à" with "à" works fine.
Try Using 'LookAt:=xlPart' instead of using 'LookAt:=xlWhole'
Columns(icount).Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns(icount).Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
You could it like so:
Sub rep()
For Each c In Sheets("Sheet1").Range("A:A").Cells ' Change the range that you want
If InStr(c.Value, ",") > 0 Then
deli = Split(c, "")
For a = 0 To UBound(deli)
c.Value = replace(c.Value, ",", "")
Next a
End If
If InStr(c.Value, "-") > 0 Then
deli = Split(c, "")
For a = 0 To UBound(deli)
c.Value = replace(c.Value, "-", "")
Next a
End If
Next c
End Sub

Looping through Word documents to extract table data and place into Excel

I currently need to extract data from a Word table and place it into Excel. I am able to do this on a file by file basis. I need to be able to loop through all the word documents in a file path.
More specifically, I need to be able to open up a word file read the info from the tables on that word file import the information needed below, close that word file and then repeat for all word files (doc, or docx) in a specified folder.
Currently my code is this:
Sub ImportWordTable()
Dim eRow As Long
Dim ele As Object
Dim mainBook As Workbook
Set mainBook = ActiveWorkbook
mainBook.Sheets("Sheet1").Range("A:BB").Clear
Set sht = Sheets("sheet1")
Application.Goto (ActiveWorkbook.Sheets("Sheet1").Range("A1"))
Dim wordDoc As Object
Dim wdFileName As Variant
Dim noTble As Integer
Dim rowNb As Long
Dim colNb As Integer
Sheet1.Range("A1").Select
Dim x As Long, y As Long
x = 1: y = 1
Dim sPath As String
Dim sFil As String
Dim owb As Workbook
Dim twb As Workbook
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub
Set wordDoc = GetObject(wdFileName)
With wordDoc
noTble = wordDoc.tables.Count
If noTble = 0 Then
MsgBox "No Tables in this document", vbExclamation, "No Tables to Import"
Exit Sub
End If
For k = 1 To noTble
With .tables(k)
For rowNb = 1 To .Rows.Count
For colNb = 1 To .Columns.Count
Cells(x, y) = WorksheetFunction.Clean(.cell(rowNb, colNb).Range.Text)
y = 0
Next colNb
y = 1
Next rowNb
End With
x = x + 1
Next
Range("A1").Select
ActiveCell.Replace What:="Cotnact InformationName", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
ActiveCell.Replace What:="Email", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
ActiveCell.Replace What:="Contact InformationName", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
ActiveCell.Replace What:="Address", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="Location", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
ActiveCell.Replace What:="Phone", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="Cell", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="Fax", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="Re:", Replacement:=":", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A3").Select
ActiveCell.Replace What:="Preferred Position and RoutePreferred Position(s)" _
, Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="preferred Route(s)", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A4").Select
ActiveCell.Replace What:="Experience ad skillsDriving experience", _
Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="Experience and skillsDriving experience", _
Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="trucks driven", Replacement:="", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="other skills/experience", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
ActiveCell.Replace What:="licensingdriver License", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
Range("A5").Select
ActiveCell.Replace What:="licensingdriver License", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
ActiveCell.Replace What:="license number", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="state/prov.", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="hazmat", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A6").Select
ActiveCell.Replace What:="driving recordlicense ever suspended?", _
Replacement:=":", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="DUI's", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="DUis", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveCell.Replace What:="moving violations in last 3 years", Replacement:= _
"", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="preventable accidents in last 3 years", _
Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Replace What:="employment status", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A7").Select
ActiveCell.Replace What:="employment status", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A8").Select
ActiveCell.Replace What:="job history", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveCell.Replace What:="profile summary", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A9").Select
ActiveCell.Replace What:="Resume", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1:A6").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 2), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
Range("B9").Select
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B1:I1"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
Dim BlankRow As Long
BlankRow = Range("A65000").End(xlUp).Row + 1
Cells(BlankRow, 1).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A2"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 9).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B3:C3"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 10).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B4:D4"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 12).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B5:F5"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 15).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("B6:E6"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 20).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A7"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 24).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A8"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 25).Select
ActiveSheet.Paste
Application.Goto (ActiveWorkbook.Sheets("sheet1").Range("A9"))
Selection.Copy
Application.Goto (ActiveWorkbook.Sheets("sheet3").Range("A2"))
BlankRow = Range("A65000").End(xlUp).Cells(1, 26).Select
ActiveSheet.Paste
End With
Set wordDoc = Nothing
End Sub

Resources