Error on automating data entry - vba

I recorded a macro & integrated together with some codes I researched and tested, which worked individually. However, having combined them all together, I stumbled across errors running the macro. Pop out a message box which displays
Compile Error: Expected End With
Would appreciate all the help I could get to solve it
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub

You've missed and end with at the bottom of your code.
Try this (untested)
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End with
End Sub

Related

VBA- Copy and filter a specific columns to a sheet from a workbook

I already got how can i copy specific column from another workbook but now i also need to filter a specific column. I have tried this code but i encounter an error "Subscript out of range".
I need to filter Column C that contains "Mary" and copy its corresponding data.
This is the sample of my code, I know there is something wrong with my syntax especially in using auto filter for COLUMN C and copying different column and paste it to another workbook. Please help me to make it right. Thanks
Sub RAWtransfertoTRUST()
Dim MainWorkfile As Workbook
Dim OtherWorkfile As Workbook
Dim TrackerSht As Worksheet
Dim FilterSht As Worksheet
Dim lRow As Long, lRw As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' set workbook object
Set MainWorkfile = ActiveWorkbook
' set the worksheet object
Set TrackerSht = MainWorkfile.Sheets("Trust Activities Raw")
With TrackerSht
lRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Application.AskToUpdateLinks = False
' set the 2nd workbook object
Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)
' set the 2nd worksheet object
Set FilterSht = OtherWorkfile.Sheets("Raw Data")
With FilterSht
.AutoFilterMode = False
.Range("B2:F").AutoFilter Field:=3, Criteria1:="Mary"
lRw = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
' paste
TrackerSht.Range("B" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row
.Range("J1:J" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("G" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("N1:Q" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("H" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("T1:W" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("L" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("Y1:Z" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("P" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("AB1:AC" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("R" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
So, a few issues here.
In this code block:
With FilterSht
.AutoFilterMode = False
.Range("B2:F").AutoFilter Field:=3, Criteria1:="Mary"
lRw = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
You are missing a number in the range B2:F. If you want to filter the entire column, then both you should exclude the number "2" from B2. I assume that you were wanting to use the lRw that is actually on the next line, so this would need to go above your range line, then you would need to include that with your B2:F by adding & lRw.
That line should now look like:
.Range("B2:F" & lRw).AutoFilter Field:=2, Criteria1:="Mary"
Also, keep in mind that this is not including row 2 in your autofilter. I assume you were wanting to filter row 2, so you would need to change it to B1: if this was the case.
Next issue is your copy / paste method. You are not pasting anything, because you never copied it. In the same With block, you can add this line: .AutoFilter.Range.Copy
Here's your final result:
Sub RAWtransfertoTRUST()
Dim MainWorkfile As Workbook, OtherWorkfile As Workbook
Dim TrackerSht As Worksheet, FilterSht As Worksheet
Dim lRow As Long, lRw As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set MainWorkfile = ActiveWorkbook
Set TrackerSht = MainWorkfile.Sheets("Trust Activities Raw")
With TrackerSht
lRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Application.AskToUpdateLinks = False
Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)
Set FilterSht = OtherWorkfile.Sheets("Raw Data")
With FilterSht
.AutoFilterMode = False
lRw = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B1:F" & lRw).AutoFilter Field:=3, Criteria1:="Mary"
.AutoFilter.Range.Copy
End With
' paste
TrackerSht.Range("B" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row
.Range("J1:J" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("G" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("N1:Q" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("H" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("T1:W" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("L" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("Y1:Z" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("P" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With FilterSht
If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row ' last row with data in column "C"
.Range("AB1:AC" & lRw).Copy ' copy your range
End With
' paste
TrackerSht.Range("R" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Oh, and I slightly cleaned up your code formatting :D
Thanks for all your help, i already resolved my issue. I just filter all the columns then delete the columns that i don't need. This is my sample code.
Sub RAWtransfertoTRUST()
Dim MainWorkfile As Workbook, OtherWorkfile As Workbook
Dim TrackerSht As Worksheet, FilterSht As Worksheet
Dim lRow As Long, lRw As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set MainWorkfile = ActiveWorkbook
Set TrackerSht = MainWorkfile.Sheets("Trust Activities Raw")
With TrackerSht
lRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
Application.AskToUpdateLinks = False
Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)
Set FilterSht = OtherWorkfile.Sheets("Raw Data")
With FilterSht
.AutoFilterMode = False
lRw = .Cells(.Rows.Count, "C").End(xlUp).Row
.Range("B1:W" & lRw).AutoFilter Field:=2, Criteria1:="Mary"
.AutoFilter.Range.Copy
End With
TrackerSht.Range("B" & lRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
With TrackerSht
.Range("G:I,K:M,R:S,X:AD").DELETE Shift:=xlToLeft
.Range("E:E").Copy
.Range("G:O").PasteSpecial Paste:=xlPasteFormats
.Range("G2", "G1000").NumberFormat = "dd/mm/yyyy"
.Range("M2", "M1000").Interior.ColorIndex = 41
.Range("J2", "J1000").Interior.ColorIndex = 6
End With
End Sub

Error re-running code

firstly, I'm having error running the code from Excel workbook directly. It leads to the error message mentioned below
We looked at all the data next to your selection and didn't see a pattern for filling in values for you. To use Flash Fill, enter a couple of examples of the output you'd like to see, keep the active cell in the column you want filled in and click the Flash Fill button again
However, I could run the code if is played from VBA windows under the developers tab. But Is limited to only 1 run before an error message 1004 pops up and also code error when played again.
Please help. Never taught or learnt VBA in ever. Code below is a mash up of researched on the net and trial & error.
Sub Graph()
'
' Graph Macro
'
' Keyboard Shortcut: Ctrl+e
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Area3-LG").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
'Error with rng.select when Macro is runned again
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("InstData_TEMS_Existing").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Area3-LG").Activate
Sheets("Graph data").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub
Thanks in advance (:
Try the code below, without all the unnecessary Select, Activate, and Selection:
Sub Graph()
'
' Graph Macro
'
' Keyboard Shortcut: Ctrl+e
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
With Workbooks("Area3-LG").Sheets("Graph data")
LR = .Range("B" & .Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
End With
rng.Copy ' copy the union range (no need to select it first)
' paste without all the selecting
With Windows("InstData_TEMS_Existing").Sheets("L")
' Paste (without select) un the next empty cell fromn column AA
.Range("AA" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
'Go back to previous workbook & delete column
Workbooks("Area3-LG").Sheets("Graph data").Columns("B:B").Delete Shift:=xlToLeft
End Sub

Copy variable range of values not formulas

I'm trying to copy a variable range from one book (Book1) to the end of a variable range of the another book (book2). I'm interested only in values of the variable range in the book 1 and this is the problem. So I need to find the last row of values (not formulas). On this forum I found several options but none of them works in my case. Here is what I got (Please see the second part of the code "Copy Detail USHB"-'Select cells to copy):
''''''Copy Detail by Vendor''''''
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Detail by Vendor")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
Workbooks.Open Filename:= _
"Book2.xlsm"
'Set selectedworkbook
Set wb2 = ActiveWorkbook
'Select cells to copy
Sheets("By Vendor").Select
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail by Vendor").Select
'Paste starting at the last empty row
wb.Worksheets("Detail by Vendor").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
'''''Copy Detail USHB'''''
'Last cell in column
Set WS = Worksheets("Detail USHB")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
'Activate the target workbook
wb2.Activate
'Select cells to copy
Sheets("Detail USHB").Select
Dim jLastRow As Long
jLastRow = Columns("B").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range(Selection, ActiveCell.SpecialCells(xlLastRow).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail USHB").Select
'Paste starting at the last empty row
wb.Worksheets("Detail USHB").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Following your comments, I believe you are trying to do the following:
'...
'''''Copy Detail USHB'''''
Dim D As Range
Dim S As Range
With wb2.Worksheets("Detail USHB")
'Locate the last non-blank value in source range
LastRow = .Range("B:B").Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
'Set range
Set S = .Range("B2:B" & LastRow)
End With
With wb.Worksheets("Detail USHB")
'Find last used cell in destination range
Set D = .Range("B" & .Rows.Count).End(xlUp)
'Offset to next row, and resize appropriately
Set D = D.Offset(1, 0).Resize(LastRow - 1, 1)
End With
'Copy values
D.Value = S.Value
End Sub

Trying to copy specific columns in a row to another excel sheet based on it meeting certain criteria

Im very new to excel/vba and trying to use a macro to check a column for the value true, when it sees that value I'd like it to copy parts of that row to another sheet in my column. Then I need it to iterate through the other rows and perform the same checks. Here is my code currently.
Sub Macro3()
'
' Macro3 Macro
'
'
Sheets("Aspen Data").Select
Dim tfCol As Range, Cell As Object
Set tfCol = Range("G26:G56")
Sheets("Code").Select
ActiveSheet.Calculate
Sheets("Aspen Data").Select
ActiveSheet.Calculate
For Each Cell In tfCol
If IsEmpty(Cell) Then
Exit Sub
End If
If Cell.Value = "True" Then
Range("I26:Q26").Select
Selection.Copy
Sheets("AspenHist").Select
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
End Sub
The issue appears to be in getting my Range("I26:Q26) to increment by one as it goes through the loop.
Try this
Sheets("Aspen Data").Select
Dim i As Integer
Sheets("Code").Calculate
Sheets("Aspen Data").Calculate
For i = 26 To 56
If IsEmpty(Cells(i, 7)) Then
Exit Sub
ElseIf Cells(i, 7).Value = "True" Then
Range(Cells(i, 9), Cells(i, 12)).Copy
Sheets("AspenHist").Activate
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Aspen Data").Activate
End If
Next i
There's no need to use .Select/.Activate/ActiveSheet (see this) to accomplish your goals, and you can definitely use For Each. Try this:
Option Explicit
Sub Macro1()
'
' Macro1 Macro
'
'
Dim tfCol As Range, Cell As Object
Set tfCol = Sheets("Aspen Data").Range("G26:G56")
Application.ScreenUpdating = False
Sheets("Code").Calculate
Sheets("Aspen Data").Calculate
For Each Cell In tfCol
If IsEmpty(Cell) Then
Exit For
End If
If Cell.Value = "True" Then
Sheets("Aspen Data").Range("I" & Cell.Row & ":Q" & Cell.Row).Copy
Sheets("AspenHist").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Next
Application.ScreenUpdating = True
End Sub

Copying formula and Format from row above Macro

I have a spreadsheet for entering a new set of data on a new row each day each day, the row contains formulas and formatting. I want to be able to click a button and it adds a row under the last row with entered data and copy the formulas and formatting only, ready for new data to be entered.
Below is my code:
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
Set ws = ThisWorkbook.Sheets("Summary")
With ws
varUserInput = .Range("D" & .Rows.Count).End(xlUp).Row
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub
The issue is that it will only copy the formula from the same hidden row each time.
Is this what you are trying (UNTESTED)?
Sub Button1_Click()
Dim ws As Worksheet
Dim varUserInput As Variant
varUserInput = InputBox("Enter Row Number where you want to add a row:", "What Row?")
If varUserInput = "" Then Exit Sub
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Change as applicable
With ws
.Rows(varUserInput).Insert Shift:=xlDown
.Rows(1).Copy .Rows(varUserInput)
.Rows(varUserInput - 1).Copy
.Rows(varUserInput).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End Sub