I'm trying to write a macro that will copy a row to another sheet if certain values are met. There are multiple possible destinations. This is what I've pieced together, but I'm sure it's messy. Basically, if in column 14 there is "N/A" and in column 8 there is "APP" then copy that to the APP tab. And so on for Angie, Cathy, etc.
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Reconciliation")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("APP")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Angie")
Dim ws4 As Worksheet: Set ws4 = ThisWorkbook.Sheets("Cathy")
Dim ws5 As Worksheet: Set ws5 = ThisWorkbook.Sheets("Cory")
Dim ws6 As Worksheet: Set ws6 = ThisWorkbook.Sheets("Curt")
For Each i In ws1.Range("A1:A1000")
If ws1.Cells(i, 14) = "#N/A" Then
If ws1.Cells(i, 8) = "APP" Then
ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
End If
End If
Next i
This will copy the row if there's a sheet with a matching name:
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Reconciliation")
Dim ws
For Each i In ws1.Range("A1:A1000").Cells
If ws1.Cells(i.Row, 14).Value = cverr(2042) Then
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Sheets(ws1.Cells(i.Row, 8).Value)
on error goto 0
If Not ws Is Nothing Then
i.EntireRow.Copy ws.Rows(ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + 1)
End If
on error goto 0
End If
Next i
Related
Trying to loop though the worksheets to apply the filter on date, and copy all the filtered data into a "Report" sheet.
Here is code, which loops only the first sheet ( USD) and not the second one (EUR).
Sub SheetLoop()
Dim Ws As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim Rng As Range
Dim CRng As Range
Dim DRng As Range
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.Name <> DestSh.Name Then
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
End If
Next Ws
End Sub
Since AdvancedFilter needs the filtered range headers, you cannot copy only part of the filtered range, but you can delete the first row of the copied range, except the first copied range (from first sheet):
Sub SheetLoop()
Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
Dim Rng As Range, CRng As Range, DRng As Range, i As Long
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.name <> DestSh.name Then
i = i + 1
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
If i > 1 Then DRng.cells(1).EntireRow.Delete xlUp 'delete the first row of the copied range, except the first case
Set DRng = DestSh.Range("A" & DestSh.rows.count).End(xlUp).Offset(1) 'reset the range where copying to
End If
Next Ws
MsgBox "Ready..."
End Sub
I have the below code which applies a filter to a Pivot Table, then specific data is copied from the PivotTable and the filters are removed.. The issue is, this one block of code is used 22 times, the sub is waaaay too long.
Here is the code I have with only ONE of the blocks:
Option Explicit
Sub FilterPivotTable()
Dim rLastCell As Range
Dim PvtTbl As PivotTable
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRow1 As Long
Set ws1 = ActiveWorkbook.Sheets("PivotTable")
Set ws2 = ActiveWorkbook.Sheets("Summary")
Dim rowCount As Long
LastRow1 = ws1.Cells(Rows.Count, 1)
'Microsoft Windows
Application.ScreenUpdating = False
ws1.PivotTables("P1").ManualUpdate = True
ws1.PivotTables("P1").PivotFields(" Vulnerability Name").ClearAllFilters
'---------------Block Starts Here---------------
ws1.PivotTables("P1").PivotFields(" Vulnerability Name").PivotFilters. _
Add Type:=xlCaptionContains, Value1:="Microsoft Windows"
ws1.PivotTables("P1").ManualUpdate = False
Application.ScreenUpdating = True
With ws1.PivotTables(1).TableRange1
Set rLastCell = .Cells(.Rows.Count, .Columns.Count)
Set PvtTbl = Worksheets("PivotTable").PivotTables("P1")
rLastCell.Copy
With ws2
.Cells(LastRow1 + 2, 3).PasteSpecial xlPasteValues
.Range("$B$2").Value = "Microsoft Windows"
rowCount = PvtTbl.DataBodyRange.Rows.Count
.Range("$D$2") = rowCount - 1
End With
End With
ws1.PivotTables("P1").PivotFields(" Vulnerability Name").ClearAllFilters
'---------------Block Ends Here---------------
End Sub
This block of code is repeated 22 times throughout this sub, each time only changing the vulnerability name i.e. Changing 'Microsoft Windows' to 'Adobe' and then changing the Cell Reference for where the data is to be copied to the Summary Sheet.
I am hoping to rather have one block of code that loops through the vulnerability names instead of having 22 different blocks of code performing the same function.
This is what the Pivot Table Structure looks like:
The filter is done under the rows block and done on Vulnerability Name
This is a bit of a punt in the dark I'm afraid
Option Explicit
Sub FilterPivotTable()
Dim rLastCell As Range
Dim PvtTbl As PivotTable
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ActiveWorkbook.Sheets("PivotTable")
Set ws2 = ActiveWorkbook.Sheets("Summary")
Dim rowCount As Long
Dim LastRow1 As Long
Dim pvtField As PivotField
Set PvtTbl = ws1.PivotTables("P1")
Application.ScreenUpdating = False
Set pvtField = PvtTbl.PivotFields(" Vulnerability Name") 'extend etc as required
Dim myArr()
myArr = Array("Microsoft Windows", "Adobe Reader", "Other")
'PvtTbl.ManualUpdate = False
Dim i As Long
For i = LBound(myArr) To UBound(myArr)
pvtField.ClearAllFilters
pvtField.PivotFilters. _
Add Type:=xlCaptionContains, Value1:=myArr(i)
With ws1.PivotTables(1).TableRange1
Set rLastCell = .Cells(.Rows.count, .Columns.count) 'grand total?
End With
With ws2
LastRow1 = ws2.Cells(ws2.Rows.count, 3).End(xlUp).row
rLastCell.Copy
.Cells(LastRow1 + 1, 3).PasteSpecial xlPasteValues
.Cells(LastRow1 + 1, 2).Value = myArr(i)
rowCount = PvtTbl.DataBodyRange.Rows.count
.Cells(LastRow1 + 1, 4) = rowCount - 1
End With
Next i
Application.ScreenUpdating = True
'PvtTbl.ManualUpdate = False
End Sub
Hello i have this code my question is about inputbox. My inputbox is used for adressing to last folder where are my reports saved. But i want value of this inputbox (which is January 2018) also use in sub spracovanie2 to safe worbook in which is this code written. How can i make one inputbox to work for two sub precodures. I don't want to wrie same value two times. Can i make it public somehow?
Please comment if you think i don't expressing myself clearly.
Sub Spracovanie1()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim mesiac_rok As String
mesiac_rok = InputBox("Mesiac/Rok")
Set wb = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks.Open("????????\" & mesiac_rok & "\??????.xlsx")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng = ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0)
Set rng2 = ws2.Range("B4").CurrentRegion.Offset(1, 0)
rng2.Resize(rng2.Rows.Count - 1).Copy Destination:=rng
wb2.Close
Set wb2 = Workbooks("?????.xlsm")
Set ws2 = wb2.Sheets("Check List Action plan Opr")
Set rng2 = ws2.Range("B1")
ws.UsedRange.Copy Destination:=rng2
wb.SaveAs Filename:=("????????\" & mesiac_rok & "\??????.xlsx)"
wb.Close
End Sub
Sub Spracovanie2()
'
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim LastRow As Long
Set wb = Workbooks("Reporting AP Bwise source.xlsm")
Set ws = wb.Sheets("Check List Action plan Opr")
Set rng = ws.Range("B4").CurrentRegion
Set ws2 = wb.Sheets("OPR Action plans_TEMP")
rng.Copy Destination:=ws2.Range("A1")
ws2.Range("A1").CurrentRegion.UnMerge
LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range("A1:AP" & LastRow).Sort Key1:=ws2.Range("N1:N" & LastRow), _
Order1:=xlAscending, Header:=xlYes
Set ws = wb.Sheets("OPEN AP")
ws.UsedRange.ClearContents
Set ws2 = wb.Sheets("CLOSED AP")
ws2.UsedRange.ClearContents
end sub
I am trying to write a program which would take the information from a user selected grid and the information adjacent to it and send them to another workbook. However, whenever I compile, I would get the error 1004 (Automation). Can someone please point out where I have made a mistake in my code? It will be greatly appreciated.
Sub CopyItemsByLocation()
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim strName As String
Dim i As Integer
Dim rng1 As Range
Set wbThis = ActiveWorkbook
Set wsThis = ActiveSheet
strName = ActiveSheet.Name
Set wbTarget = Workbooks.Open("C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx")
Set wsTarget = wbTarget.Worksheets(strName)
Set rng1 = Selection
For i = 1 To 4
If i = 1 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5") **'<~Error occurs here**
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 2 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("G5")
Set rng1 = rng1.Offset(0, 1)
ElseIf i = 3 Then
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("I5")
Set rng1 = rng1.Offset(0, 1)
Else
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("K5")
Set rng1 = rng1.Offset(0, 1)
End If
Next i
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
rng1 is already a range so
wsThis.Range(rng1).Copy Destination:=wsTarget.Range("E5")
should be
rng1.Copy Destination:=wsTarget.Range("E5")
Also might want to set rng1 before opening the other workbook
Reworked a bit:
Sub CopyItemsByLocation()
Const WB As String = "C:\Users\Administrator\Desktop\Excel Testing\Excel Info Testing 2.xlsx"
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim rng1 As Range
Set rng1 = Selection.Cells(1) 'in case of >1 cell selected
Set wbTarget = Workbooks.Open(WB)
Set wsTarget = wbTarget.Worksheets(rng1.Parent.Name)
rng1.Copy wsTarget.Range("E5")
rng1.Offset(0, 1).Copy wsTarget.Range("G5")
rng1.Offset(0, 2).Copy wsTarget.Range("I5")
rng1.Offset(0, 3).Copy wsTarget.Range("K5")
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
End Sub
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws