Copy specific row to another workbook based on a cell value - vba

I want to copy row(A:E), row(F:AH), and row(AL)from the active workbook to row(A:E), row(G:AI), row(AJ) of another workbook. Here's the code that I'm working on. I saw it here and just edited it.
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim ret
ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _
Title:="Select data file for Monitoring Log")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Macro Template")
strSearch = "Newly Distributed"
With ws1
.AutoFilterMode = False
lRow = .Range("AL" & .Rows.Count).End(xlUp).Row
With .Range("AL7:AL" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open(ret)
Set ws2 = wb2.Worksheets("Source")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
wb2.Save
wb2.Close
This code copies the entire row. How can I revise it to copy specific rows.

Replace
copyFrom.Copy .Rows(lRow)
with
copyFrom.Columns("A:E").Copy .Cells(lRow, "A")
copyFrom.Columns("F:AH").Copy .Cells(lRow, "G")
copyFrom.Columns("AL").Copy .Cells(lRow, "AJ")

From the source code, i just could see you copy the data from the column AL to another worksheet.
I modified your code and it successfully copy to the another worksheet. The copy function could be written in 1 line instead of multiple line.
Option Explicit
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim strSearch As String
Sub Test()
Dim ret
ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _
Title:="Select data file for Monitoring Log")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Macro Template")
strSearch = "Newly Distributed"
With ws1
.AutoFilterMode = False
lRow = .Cells(Rows.Count, "AL").End(xlUp).Row
'lRow = .Range("AL" & .Rows.Count).End(xlUp).Row
With .Range("AL7:AL" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
End With
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open(ret)
Set ws2 = wb2.Worksheets("Source")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
Else
lRow2 = 1
End If
'copyFrom.Copy .Rows(lRow)
ws1.Range("AL8:AL" & lRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ws2.Range("A" & lRow2)
End With
'~~> Remove any filters
ws1.AutoFilterMode = False
wb2.Save
wb2.Close
End Sub

Related

Find Data Between Dates and Copy Them to New Workbook

I am trying to create a report feature for a machine downtime tracker I have created for work. I have a userform which asks for the machine name, as well as the date range they would like to get data from. I would like this to open the workbook where the data is stored, capture the data they want and copy it to a new workbook.
After searching on here for a while I was able to put something together with the autofilter feature, but I cannot get any of the data to show up on the new sheet. I think it may have something to do with the Date, but I can't seem to figure it out. Here is my code:
Public Sub cmdSubmit_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim startDate As Date, endDate As Date
Set wb1 = Workbooks.Open("FILEPATH")
'~~> Checks to see what sheet the data should be copied from based on the combo box entry.
If Me.cmboWorkCenter.Value = "Machine1" Then
Set ws1 = wb1.Sheets("Machine1")
ElseIf Me.cmboWorkCenter.Value = "Machine2" Then
Set ws1 = wb1.Sheets("Machine2")
ElseIf Me.cmboWorkCenter.Value = "Machine3" Then
Set ws1 = wb1.Sheets("Machine3")
ElseIf Me.cmboWorkCenter.Value = "Machine4" Then
Set ws1 = wb1.Sheets("Machine4")
ElseIf Me.cmboWorkCenter.Value = "Machine5" Then
Set ws1 = wb1.Sheets("Machine5")
ElseIf Me.cmboWorkCenter.Value = "Machine6" Then
Set ws1 = wb1.Sheets("Machine6")
Else
MsgBox "ERROR"
Unload Me
End If
startDate = Me.txtStartTime.Value
endDate = Me.txtEndTime.Value
With ws1
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
With .Range("B1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">=" & startDate, Operator:=xlAnd, Criteria2:="<=" & endDate
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
''~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = Workbooks.Add
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
wb1.Close
End Sub
Any help would be appreciated!
You are working solely with column B, specifically .Range("B1:B" & lRow). The field isn't 2 it is 1 since there is only one column in .Range("B1:B" & lRow).
With .Range("B1:B" & lRow)
.AutoFilter Field:=1, Criteria1:=">=" & startDate, Operator:=xlAnd, Criteria2:="<=" & endDate
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With

Excel VBA to Remove Opt-Outs

I am a military recruiter and am trying to use autofilter to filter out a range from another range. I got this from another stackoverflow page but can not figure out how to change that string strSearch to a range like 123#gmail, 234#gmail, 345#gmail, etc.
We get lists of leads but I'd like to keep the running list of opt-outs and have VBA double check and delete any cells that have a value from the opt-out worksheet. I am pretty new to VBA but really enjoy it. Thank you!
I'd like it to be strSearch = Sheets("Opt-Outs").Range("A:A") so that it takes all values in A:A and uses them as an autofilter. I believe it needs to be a string array but am lost as how to get there. Please help.
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
This should do it...
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
Dim v() As Variant
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
v = Application.Transpose(Sheets("Opt-Outs").Range("A:A"))
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:=v
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As Variant
Dim i As Integer
i = 1
Sheets("Opt-Outs").Select
Range("H2").Value = "Ready"
Range("A2").Select
Do While Range("H2").Value <> Empty
Sheets("Opt-Outs").Select
Range("A2").Select
Cells(i + 1, 1).Copy
i = i + 1
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("H2").Value = IsBlank Then
Sheets("Email Addresses").Select
Exit Sub
Else
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("H2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Loop

Copying certain columns VBA

I have a working VBA macro which copies from one spreadsheet 'AverageEarnings' to another 'Sheet1', under the condition that Column AO has the word 'UNGRADED' in it. The macro copies the entirety of these conditional rows to Sheet1. I am looking to copy columns B and C ('AverageEarnings') to columns A and B ('Sheet1'). How do I amend this.
Sub UngradedToSHEET1()
' UngradedToSHEET1 Macro
'
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim stringToFind As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("AverageEarnings")
stringToFind = "UNGRADED"
With ws1
'Remove all filters from spreadsheet to prevent loss of information.
.AutoFilterMode = False
lRow = .Range("AO" & .Rows.Count).End(xlUp).Row 'Find a specific column.
With .Range("AO1:AO" & lRow) ' This is the row where GRADED or UNGRADED is specified.
.AutoFilter Field:=1, Criteria1:="=*" & stringToFind & "*" 'Filter specific information.
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'Remove spreadsheet filters again.
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Sheet1")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then ' Find a blank row after A1.
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
End Sub
This line copies the entire row:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
You will need to change EntireRow to just copy the columns you want, probably something like:
Set copyFrom =
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Range(.Cells(1,2),.Cells(1,3))
Hope this helps, I can't check this right now.

Copy sheet from one WB to another using VBA without opening destination WB

I'm new to VBA and trying to automate updates to a workbook.
I have a source Workbook A and a destination Workbook B. Both have a sheet called roll out summary. I want the user to update this sheet in A and click update button which should run my macro. This macro should automatically update the sheet in workbook B without opening Workbook B.
I'm trying this code but it doesn't work and gives me an error:
Dim wkb1 As Workbook
Dim sht1 As Range
Dim wkb2 As Workbook
Dim sht2 As Range
Set wkb1 = ActiveWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Worksheets("Roll Out Summary") <Getting error here>
Set sht2 = wkb2.Sheets("Roll Out Summary")
sht1.Cells.Select
Selection.Copy
Windows("B.xlsx").Activate
sht2.Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
sht1 and sht2 should be declare as Worksheet. As for updating the workbook without opening it, it can be done but a different approach will be needed. To make it look like you're not opening the workbook, you can turn ScreenUpdating on/off.
Try this:
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open("B.xlsx")
Set sht1 = wkb1.Sheets("Roll Out Summary")
Set sht2 = wkb2.Sheets("Roll Out Summary")
sht1.Cells.Copy
sht2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True
Application.ScreenUpdating = True
Use this - This worked for me
Sub GetData()
Dim lRow As Long
Dim lCol As Long
lRow = ThisWorkbook.Sheets("Master").Cells()(Rows.Count, 1).End(xlUp).Row
lCol = ThisWorkbook.Sheets("Master").Cells()(1, Columns.Count).End(xlToLeft).Column
If Sheets("Master").Cells(2, 1) <> "" Then
ThisWorkbook.Sheets("Master").Range("A2:X" & lRow).Clear
'Range(Cells(2, 1), Cells(lRow, lCol)).Select
'Selection.Clear
MsgBox "Creating Updated Master Data", vbSystemModal, "Information"
End If
'MsgBox ("No data Found")
'End Sub
cell_value = Sheets("Monthly Summary").Cells(1, 4)
If cell_value = "" Then
Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
MsgBox (cell_value)
Path = "D:\" & cell_value & "\"
Filename = Dir(Path & "*.xlsx")
If Filename = "" Then
Filename = InputBox("No Such File Found,Enter File Path Manually", "Bad Request")
Else
Do While Filename <> ""
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
ActiveWorkbook.Sheets("CCA Download").Activate
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Range("A2:X" & LastRow).Select
Selection.Copy
ThisWorkbook.Sheets("Master").Activate
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Select
'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial xlPasteValues
Workbooks(Filename).Close
Filename = Dir()
Loop
End If
End If
Sheets("Monthly Summary").Activate
'Sheets("Monthly Summary").RefreshAll
Dim pvtTbl As PivotTable
For Each pvtTbl In ActiveSheet.PivotTables
pvtTbl.RefreshTable
Next
'Sheets("Monthly Sumaary").Refresh
MsgBox "Monthly MIS Created Sucessfully", vbOKCancel + vbDefaultButton1, "Sucessful"
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Excel VBA - Find and Replace from External File

I have a file that I would like to run a Find and Replace on using data from another Excel file.
I have this so far, what am I doing wrong?
Sub LegalName()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet
Set NameListWB = Workbooks.Open("File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
Dim rng As Range
Set rng = NameListWS.Range("A:B").Select
Do Until IsEmpty(ActiveCell)
Worksheets("Sheet1").Columns("F").Replace _
What:=ActiveCell.Value, Replacement:=ActiveCell.Offset(0, 1).Value, _
SearchOrder:=xlByColumns, MatchCase:=False
ActiveCell.Offset(1, 0).Select
Loop
End Sub
I see that you started by declaring your objects but missed out on few. Also, you need to avoid the use of .Select Interesting Read
Is this what you are trying (UNTESTED)?
Sub Sample()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'~~> This is the workbook from where your code is running
Set thisWb = ThisWorkbook
'~~> Change this to the sheet name where you want to replace
'~~> in Column F
Set thisWs = thisWb.Sheets("Sheet1")
'~~> File.xlsx
Set NameListWB = Workbooks.Open("C:\File.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'~~> Find last row in Col A of File.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop though Col A
For i = 1 To lRow
'~~> Do the replace
thisWs.Columns(6).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub