If the cells is equal to Disney Orlando I want to move to worksheet New or a completely new worksheet. As of now the .Rows is causing an error.
Sub finddisneys()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("April")
Set ws2 = wb.Sheets("alljobs")
Set ws3 = wb.Sheets("New")
i = ws1.Cells(Rows.Count, 2).End(xlUp).Row
For i = z To 2 Step -1
If ws1.Cells(i, 2) = "Disney Orlando" Then
.Rows(i).Copy Destination:=ws3.range("A")
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Just need to do some "housekeeping" on the code:
Sub finddisneys()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("April")
Set ws2 = wb.Sheets("alljobs")
Set WS3 = wb.Sheets("New")
i = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).row ' Added ws1 before "Rows" for clarity
For i = z To 2 Step -1
If ws1.Cells(i, 2) = "Disney Orlando" Then
ws1.Rows(i).copy Destination:=WS3.Range("A") ' Added ws1, since you didn't have `With` anywhere.
End If
Next i ' Need this to continue the loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Edit: Ah, I see Scott and Jeeped are all over it.
Related
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
Why code doesn't pick cell in next worksheet? My copy workbook contain 12 worksheets.
Sheet.Name = ("cat","rabbit","cow","sheep"...+8).
Each sheet have same headers. Col(B1:AK1)= year(1979,1980,...2014).
In another folder that I repeatedly open for pasting; File.Name = (1979.xlsx, 1980.xlsx,..,2014.xlsx).
In each sheet got 12 columns . Col(B1:M1)= ("cat","rabbit","cow","sheep"...+8).
Each cell in range loop nicely but worksheet doesn't seem so. When my code finish run, I check paste workbook having the same data from worksheet("cat"). I'm not competent with coding so please advise whenever my code can be improve.
Sub transferPict()
Dim wsC As Integer
Dim cell As Range
Dim Rng As Range
Dim j, i As Long
Dim x As String
Dim Folderpath
Dim file As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
wsC = ThisWorkbook.Sheets.Count
For j = 1 To wsC
i = j + 1
Set Rng = Range("B1:AK1")
For Each cell In Rng
x = cell.Value
cell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\"
file = Folderpath & x & ".xlsx"
Workbooks.Open (file)
ActiveWorkbook.Worksheets("sheet1").Select
ActiveSheet.Cells(2, i).Select
ActiveSheet.Paste
ActiveWorkbook.Close saveChanges:=True
Next cell
Next j
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
At no point in your code were you specifying which worksheet you want to copy from, so it will always use the "active" sheet.
Hopefully this code will correct your issue:
Sub transferPict()
Dim wsC As Integer
Dim cell As Range
Dim Rng As Range
'Dim j, i As Long ' <--- This is equivalent to Dim j As Variant, i As Long
Dim j As Long, i As Long
Dim x As String
Dim Folderpath
Dim file As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
wsC = ThisWorkbook.Sheets.Count
For j = 1 To wsC
i = j + 1
Set Rng = ThisWorkbook.Sheets(j).Range("B1:AK1")
For Each cell In Rng
x = cell.Value
ThisWorkbook.Sheets(j).Range(cell.Offset(1, 0), cell.Offset(1, 0).End(xlDown)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\"
file = Folderpath & x & ".xlsx"
Workbooks.Open file
ActiveWorkbook.Worksheets("sheet1").Cells(2, i).PasteSpecial
ActiveWorkbook.Close saveChanges:=True
Next cell
Next j
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
There is a sheet scr where column P has the following view:
P1=100
P2=100
P3=100
P4=100
P4=101
P5=101
P6=102
P7=102
P8=102
, meaning there are blocks of unique values. I need to leave only the upper value (here - P1, P4, P6). The other duplicated values should be erased. Therefore, I made the code below, but it does not work and gives no error.
Sub Test()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Set src = wb1.Sheets("Modules_List")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
For i = 1 To 100
For k = 1 To 100
If .Cells(i, "P").Value = .Cells(i + k, "P").Value Then .Cells(i + k, "P").Value = ""
Next k
Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Here is your entire code over you last three questions.
Sub Copy_Data_by_Criteria()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim src As Worksheet
Dim Dst As Worksheet
Dim src2 As Worksheet
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks.Open(Filename:="C:\Test.xlsx")
Set src = wb1.Sheets("Sheet1")
Set Dst = wb2.Sheets("Sheet1")
Set src2 = wb1.Sheets("Base 1")
Dim LastRow As Long
Dim r As Range
Dim CopyRange As Range
Dim Crit As Range
Dim strValue As Variant
LastRow = src.Cells(src.Rows.Count, "P").End(xlUp).Row
For Each Crit In src2.Range("G10:G" & 30)
If Crit <> "" Then
For Each r In src.Range("P6:P" & LastRow)
If r <> 0 Then strValue = r
If strValue = Crit Then
If CopyRange Is Nothing Then
Set CopyRange = r.EntireRow
Else
Set CopyRange = Union(CopyRange, r.EntireRow)
End If
End If
Next r
End If
Next Crit
If Not CopyRange Is Nothing Then
CopyRange.Copy Dst.Range("A1")
End If
End Sub
As to why your current code did not do what you wanted, Since you looped down to add the values you need to loop up to remove them:
Sub Test()
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Set src = wb1.Sheets("Modules_List")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim k As Integer
With src
For i = 100 To 1
If .Cells(i, "P").Value = .Cells(i - 1, "P").Value Then .Cells(i, "P").Value = ""
Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have a macro that does a calculation for all sheets in a workbook, I need to copy these results(which are located in the last row of each sheet, but each row may be different for each sheet) to a master sheet(as it needs to be done for multiple files), could anyone help alter my macro to do this or even make a new one?
If needed here is my macro:
Sub Calculationallsheetsv2()
'Calculation all sheets, even when there is only headers
Dim xrng As Range, lrw As Long, lrng As Range, i As Long
Dim LstCo As Long, ws As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each ws In ActiveWorkbook.Worksheets
With ws
If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then
LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For i = 1 To LstCo
With .Columns(i)
.TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
End With
Next
lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).row
If lrw = 1 Then lrw = 2
Set lrng = .Range("A" & lrw + 2)
With .Range("A2:A" & lrw)
lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
End With
Set xrng = .Range(lrng, .Cells(lrng.row, LstCo))
lrng.AutoFill xrng, Type:=xlFillDefault
xrng.Style = "Percent"
End If
End With
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Application.CalculateFull
End With
End Sub
Below is the code to accomplish the task you have described. I put some comment, so you can understand what is going on. If you have any further questions regarding this code, ask in comment.
NOTE. There is one external function used in the code below so you need to include it in your code as well, otherwise it will not compile. Here is the code of this function - Function to find the last non-empty row in a given worksheet.
Sub Calculationallsheetsv2()
'Calculation all sheets, even when there is only headers
Const SUMMARY_SHEET_NAME As String = "Summary"
'-----------------------------------------
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim wksSummary As Excel.Worksheet
Dim arrRow As Variant
Dim lastRow As Long
'-----------------------------------------
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wkb = Excel.ActiveWorkbook
'Create [Summary] worksheet. -----------------------------------------------------
On Error Resume Next
Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME)
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = wkb.Worksheets.Add
wksSummary.Name = SUMMARY_SHEET_NAME
End If
'---------------------------------------------------------------------------------
'Iterate through all the worksheets in the workbook [wkb].
For Each wks In wkb.Worksheets
'Check the name of currently checked worksheet to exclude [Summary] worksheet
'from this process.
If wks.Name <> SUMMARY_SHEET_NAME Then
'Check if there are any non-empty cells in this worksheet.
If Application.WorksheetFunction.CountA(wks.Cells) Then
'Find the index number of the last empty row.
lastRow = lastNonEmptyRow(wks)
'Copy the content of this row into array.
arrRow = wks.Rows(lastRow).EntireRow
'Paste the content of [arrRow] array into the first empty
'row of the [Summary] worksheet.
With wksSummary
.Rows(lastNonEmptyRow(wksSummary) + 1).EntireRow = arrRow
End With
End If
End If
Next wks
'Restore screen updating and automatic calculation
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
Call .CalculateFull
End With
End Sub
EDIT
If you want to put the result into a new workbook instead of a new worksheet within the same workbook you need to replace this block of code:
'Create [Summary] worksheet. -----------------------------------------------------
On Error Resume Next
Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME)
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = wkb.Worksheets.Add
wksSummary.Name = SUMMARY_SHEET_NAME
End If
'---------------------------------------------------------------------------------
with this one:
'Create [Summary] worksheet. -----------------------------------------------------
Dim wkbSummary As Excel.Workbook
Set wkbSummary = Excel.Workbooks.Add
Set wksSummary = wkbSummary.Worksheets.Add
wksSummary.Name = SUMMARY_SHEET_NAME
'---------------------------------------------------------------------------------
I am trying to write a macro that will copy data from one worksheet to another based on column headers. Lets say in ws1 there are three columns: "product", "name", "employer" and the ws2: "product", "name", "region".
So i want the macro to do all the copying as in my original file i have over 100 column headers and it will be very time consuming for to do it myself.
I have written two macros without succes. VBA is something I cant understand for quite some time. but still managed to write something, hope you can tell me if i am going in the right direction.
this is v1
Sub Copy_rangev1()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SourceRange As Range, CopyRange As Range
Dim lastrow As Long
Dim i As Integer
Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Set Ws2 = ThisWorkbook.Worksheets("sheet2")
lastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Set SourceRange = Ws2.Range("A1").CurrentRegion
Set CopyRange = Ws1.Range("A1").CurrentRegion
For i = 1 To lastrow
If SourceRange.Cells(i, 1).Value = CopyRange.Cells(i, 1) Then
SourceRange.Cells(i + 1 & lastrow, 1).Copy Destination:=CopyRange.Range("a" & lastrow)
End If
Next i
End Sub
this v2:
Sub Copyrangev2()
Dim SourceRange As Worksheet
Dim CopyRange As Worksheet
Dim lastrow As Integer
Set SourceRange = Worksheets("Sheet2")
Set CopyRange = ThisWorkbook.Worksheets("sheet1")
Dim i As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 100
If SourceRange.Range(1, i).Value = CopyRange.Range(1, i) Then
SourceRange.Range(1, i).Offset(1, 0).Copy Destination:=CopyRange.Range(1, i)
End If
Next i
End Sub
My code is a mess, but if you want me to provide any more details leave a comment, i dont expect you to given a fully workable code, a good explanation and few suggestions will do. Thanks
How about this? This code works as follows
Iterate across each column header in ws1 and see if a matching
header exists in ws2
If a match is found, copy the column contents across to the relevant column in ws2
This will work irrespective of column order. You can change the range references to suit.
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
Sub CustomColumnCopy()
Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim cel As Range
Dim rownum As Range
Set wsOrigin = Sheets("Sheet1")
Set wsDest = Sheets("Sheet2")
Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1
If ActiveWorkbook.ProtectStructure = True Or _
wsOrigin.UsedRange.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
For Each rownum In wsOrigin.UsedRange
Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))
For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
Set rngFnd = rngDestSearch.Find(cel.Value)
If Not rngFnd Is Nothing Then
wsDest.Cells(rownum.Cells.row, rngFnd.Column).Value = wsOrigin.Cells(rownum.Cells.row, cel.Column).Value
End If
On Error GoTo 0
Set rngFnd = Nothing
Next cel
Next rownum
ActiveWindow.View = ViewMode
Application.GoTo wsDest.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Dim keyRange As Range
Set keyRange = Range("A1")
wsDest.Range("A" & LastRow(wsDest) + 1).Sort Key1:=keyRange, Header:=xlYes
End Sub