I'm running into an issue with looping through tabs in my workbook. The code I am working on is supposed to perform the following:
Loop through all worksheets except the ones titled "BOAT" & "Data"
Select cell "A2" (A2 contains the value to filter)in each worksheet that it is looping through and use it as the autofilter value for the "Data" tab
Then copy and paste the filtered data into the respective tab that is looping through.
The issue I am running into is my code isn't picking up on the active sheet in the loop. Is there a way to create a variable to for the worksheet currently being looped through?
Code below. Thank you!
Sub updatedata()
Dim ws As Worksheet
Dim wsheet2 As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> "BOAT" And ws.name <> "Data" Then
Call filter1
End If
Next ws
End Sub
Sub filter1()
Dim lastrow As Long
Dim lastrow2 As Long
Dim wSheet As Worksheet
Dim rInput As String
Application.DisplayAlerts = False
Set wSheet = ActiveSheet
rInput = wSheet.Range("A2").Value
Sheets("Data").Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("A1:Y" & lastrow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastrow2 = Range("G" & Rows.Count).End(xlUp).Row
Range("G1:G" & lastrow2).Copy
wSheet.Activate
Range("A4").PasteSpecial xlPasteValues
Rows(4).EntireRow.Delete
Application.DisplayAlerts = True
End Sub
"Is there a way to create a variable to for the worksheet currently being looped through?"
Yes, using a Worksheet variable as an argument in filter1.
Avoid using Activate or making Range calls without specifying the Worksheet.
Sub updateData()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "BOAT" And ws.Name <> "Data" Then
filter1 ws 'no need to use Call
End If
Next ws
End Sub
By passing ws as an Argument to filter1, all Range calls are fully qualified with the Worksheet in question. This is easily accomplished with a With...End With block - note the period . in front of .Range("A2").Value, .Range("A4"), etc - equivalent to myWs.Range("A2").Value, myWs.Range("A4")..., etc.
Sub filter1(myWs As Worksheet)
Dim lastRow As Long, lastRow2 As Long
Dim rInput As String
Application.DisplayAlerts = False
With myWs
rInput = .Range("A2").Value
With .Parent.Sheets("Data")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:Y" & lastRow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastRow2 = .Range("G" & .Rows.Count).End(xlUp).Row
.Range("G1:G" & lastRow2).Copy
End With
.Range("A4").PasteSpecial xlPasteValues
.Rows(4).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
Related
I am cycling through all the Green Tabs in a workbook. When I come to a row of data where there is no value in Column G, I select that row, cut it, and open another workbook entitled "Unpaid AR." In that workbook, I find the first unused row, and Paste. Everything functions properly except for the Paste - nothing pastes, and I have tried several different techniques. Any ideas what could be going wrong?
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As String
Dim i As Integer
Dim varRange As String
ARFilePath = "Unpaid AR.xlsx"
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If ws.Tab.ColorIndex = 10 Then 'If Tab is Green, Then...
ReportRows = ActiveSheet.UsedRange.Rows.Count 'Get how many rows in the report
Let ARRange = "G" & "2" & ":" & "G" & ReportRows 'Range to Inspect for Blanks
i = 2
For Each ARcell In Range(ARRange)
Let CopyRange = "A" & i & ":" & "I" & i 'Set the copy range when blank is encountered
If ARcell.Value = "" Then
Range(CopyRange).Select
Selection.Cut
Workbooks.Open ARFilePath 'Open the Unpaid AR workbook
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select 'Find the first open row
ActiveSheet.Paste 'This is where NOTHING happens
Workbooks("Unpaid AR.xlsx").Close SaveChanges:=True 'Save and close destination wkbk
Application.CutCopyMode = False
End If
i = i + 1
Next ARcell
End If
Next ws
End Sub
i change a little bit...
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As Range
Dim i As Integer
Dim varRange As String
Dim wkbTarget As Workbook
Dim ReportRows As Long
ARFilePath = ThisWorkbook.Path & "\Unpaid AR.xlsx"
Set wkbTarget = Workbooks.Open(ARFilePath) 'Open the Unpaid AR workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Tab.ColorIndex = 10 Then
ReportRows = ws.UsedRange.Rows.Count
For i = ReportRows To 2 Step -1
Set CopyRange = ws.Range("A" & i & ":" & "I" & i)
If ws.Cells(i, 7).Value = "" Then
CopyRange.Cut Destination:=wkbTarget.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
End If
Next i
End If
Next ws
wkbTarget.Close SaveChanges:=True 'Save and close destination wkbk
End Sub
BR
Bernd
I have a problem with my code. It does the trick of copy/paste correctly. However, I think there is something tricky. When I try to update my dynamic table it displays a message that the WB I'm currently working in already has data and if I want to replace it. When I choose "Yes/No" it immediately displays another column in my table that says that 81 registers are not been used in UTILITY. When I do everything by hand there are no problems. So, I guess thereĀ“s something wrong with my macro.
Option Explicit
Sub DailyTrans_MDM()
Call CopyPaste
End Sub
Sub CopyPaste()
Dim vFile As Variant
Dim folderPath As String
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
vFile = Dir(folderPath & "*.xl*")
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
Do While vFile <> ""
Application.ScreenUpdating = False
vFile = Application.GetOpenFilename("Daily Reports (*.xl*)," & "*.xl*", 1, "Select Report", "Open File", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets("ReporteCifrasControl")
End If
'--------------------------------------------------------------------------------------
wsCopyFrom.Range("A2:M" & wsCopyFrom.Range("A" & Rows.Count).End(xlUp).row).Copy
wsCopyTo.Range("A" & wsCopyTo.Range("A" & Rows.Count).End(xlUp).row + 1).PasteSpecial xlPasteValuesAndNumberFormats
wbCopyFrom.Close SaveChanges:=False
Dim rngCopy As Range, rngPaste As Range
With ActiveSheet
Set rngCopy = .Range(.Range("A2"), Cells(2, Columns.Count).End(xlToLeft))
Set rngPaste = .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).Resize(, rngCopy.Columns.Count)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Loop
End Sub
I believe you want to do this
Copy row 2 from Column A to Last Used Column (LC)
Paste this in the first Non-Used Row (LR) in Column A
Dim LC As Long
Dim LR As Long
With ActiveSheet
LC = .Cells(2, .Columns.Count).End(xlToLeft).Column
LR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngCopy = .Range(.Cells(1, 2), .Cells(LC, 2))
Set rngPaste = .Range("A" & LR)
End With
rngCopy.Copy
rngPaste.PasteSpecial xlPasteFormats
You missed some objects to be qualified in your code. No point in using the With Block if you are not going to use the With Block
Just realized you have multiple copy/pastes in your code. If this is the wrong one, use the format here to modify the other one.
What I want to add is.. Macro should delete the old from "Master"sheet and refresh the sheet1,sheet2 and sheet3
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
Sheets("Master").Name = "Master"
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy Sheets("Master") _
.Range("A" & Rows.Count).End(xlUp).Offset(1)
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Call Formatting
Next Ws
End Sub
You mean this? Delete the data on Master before pasting it?
(Also stop changing the edits on your post)
Sub Combine3Sheet()
Dim Ary As Variant
Dim Ws As Worksheet
Ary = Array("Sheet1", "Sheet2", "Sheet3")
'Refresh all sources/Tables
ThisWorkbook.RefreshAll
'Clear All but first Row
Sheets("Master").Rows("2:" & Rows.Count).ClearContents
'Loop sheets
For Each Ws In Worksheets(Ary)
Ws.UsedRange.Offset(1).Copy
Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Call Formatting
Next Ws
End Sub
I am very new to the world of code and VBA - but I am having a lot of fun learning and exploring just how powerful these tools are.
I am working on pulling data from one worksheet and placing it in my "master roadmap" spreadsheet. Just a little background: In the master sheet, I have been inserting data in columns A-S; however, column 'A' is reserved on the worksheet I am pulling data from so this is why the range below is set as Range (B:T). I am scanning columns by B:T; pulling that data and inserting it in columns A:S of my master sheet. However, my boss wants to make a change reserve columns "U' through "AD" on her spreadsheet.
So I would like to have VBA scan through two ranges "B:T" and then "AE:BB" (skipping U:AD) and then plug that information in my "master sheet" into columns "A:AQ."
In short, I am hoping all I have to do is insert a 'second range' in the code below to complete this task. Any help would be greatly appreciated!
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow As Double
Dim lastrow As Double
Dim MasterWorkbook As Workbook
Dim TempWorkbook As Workbook
Dim DirPath As String
'Clear current data
Sheet1.Visible = xlSheetVisible
Sheet2.Visible = xlSheetHidden
Sheet3.Visible = xlSheetHidden
Sheet1.Activate
lastrow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If lastrow > 1 Then
Range("A2:AQ" & lastrow).Select
Selection.Clear
End If
DirPath = "C:\Users\rspktcod\Documents\RoadMap Test\Roadmaps\"
MyFile = Dir(DirPath)
Set MasterWorkbook = ActiveWorkbook
Do While Len(MyFile) > 0
Set TempWorkbook = Workbooks.Open(DirPath & MyFile)
lastrow = ActiveWorkbook.ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Range("B2:T" & lastrow).Copy
MasterWorkbook.Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Roadmap").Range(Cells(erow, 1), Cells(erow, 43))
TempWorkbook.Activate
Application.CutCopyMode = False
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
The short answer is, yes, you can just add another range.
Here is the long answer (with a few improvments...):
Sub LoopThroughDirectory()
Dim DirPath As String, MyFile As String
Dim LastRow As Long, eRow As Long ' Rows should be Long
'Dim MasterWorkbook As Workbook
Dim TempWorkbook As Workbook
Dim DestSheet As Worksheet
'Clear current data
Sheet1.Visible = xlSheetVisible
Sheet2.Visible = xlSheetHidden
Sheet3.Visible = xlSheetHidden
' Added DestSheet to be more clear, since Sheet1 is specific to this file.
' It also make the code more portable, if you want to change it to a different sheet, in a different file.
Set DestSheet = Sheet1
' MasterWorkbook is a good idea, but not required here.
'Set MasterWorkbook = ThisWorkbook 'ActiveWorkbook
LastRow = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
If LastRow > 1 Then Range("A2:AQ" & LastRow).Clear
DirPath = "C:\Users\rspktcod\Documents\RoadMap Test\Roadmaps\"
' Added "*.xls*" to limit it to just Excel Workbooks
' You don't want to process the current and previous folders, which come across as "." & ".."
MyFile = Dir(DirPath & "*.xls*")
Do While Len(MyFile) > 0
Set TempWorkbook = Workbooks.Open(DirPath & MyFile)
' Used [TempWorkbook.ActiveSheet].Rows.Count, instead of just Rows.Count to be more percise
With TempWorkbook.ActiveSheet ' <-- Not a fan of Activesheet here
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
If LastRow > 1 Then
' Excel 2003-/2007+ have different number of rows, so be specific about what sheet to get the Rows from
eRow = DestSheet.Cells(DestSheet.Rows.Count, 1).End(xlUp).Row + 1
.Range("B2:T" & LastRow).Copy Destination:=DestSheet.Cells(eRow, 1)
.Range("AE2:BB" & LastRow).Copy Destination:=DestSheet.Range("T" & eRow)
End If
TempWorkbook.Close False ' Added SaveSanges = False for good measure
MyFile = Dir
End With
Loop
End Sub
I want to copy multiple range to another workbook. I have the code below. How can I replace the number 1000 by iLastRow
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG1000, AL3:EJ1000").Select
Selection.Copy
Try the code below, explanation inside the code as comments:
Option Explicit
Sub CopyMultipleRanges()
Dim iLastRow As Long
Dim sh As Worksheet
Dim MultiRng As Range
Set sh = ThisWorkbook.Worksheets("Sheet1") ' <-- change to your sheet's name
With sh
iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
' use the union to set a range combined from multiple ranges
Set MultiRng = Union(.Range("A3:A" & iLastRow), .Range("AL3:EJ" & iLastRow))
End With
' copy the range, there's no need to select it first
MultiRng.Copy
End Sub
Another question is how you want to paste the merged reanges that have a gap in the middle.
The Union method is a solution to this problem. but it also has its cons
The union range should be the same first row and last row.
On the other hand, you can just select the first cell to paste.
you can alway do like this. the main point here is the row number should be the same. here I synchronize both range with the same variable. in your case, change to last cell.
j=1
i = 4
Set MultiRng = Union(Range("A" & j & ":B" & i), Range("D" & j & ":E" & i))
Change Range params from this:
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG1000, AL3:EJ1000").Select
To:
iLastRow = Sh.Range("B" & Rows.Count).End(xlUp).Row
sh.Range("A3:AG" & iLastrow &", AL3:EJ" & iLastRow).Select
Since with multiple selection Copy will not work. You may need to call it twice in your case. (as per suggestion by #YowE3K)
sh.Range("A3:AG" & iLastrow).Select
Selection.Copy
sh.Range("AL3:EJ" & iLastrow).Select
Selection.Copy
Option Explicit
Sub import_APVP()
Dim master As Worksheet, sh As Worksheet
Dim wk As Workbook
Dim strFolderPath As String
Dim selectedFiles As Variant
Dim iFileNum As Integer, iLastRowReport As Integer, iNumberOfRowsToPaste As Integer
Dim strFileName As String
Dim iCurrentLastRow As Integer, iRowStartToPaste As Integer
Dim MultiRng As Range
Dim startTime As Double
getSpeed (True)
Set master = ActiveWorkbook.ActiveSheet
strFolderPath = ActiveWorkbook.Path
ChDrive strFolderPath
ChDir strFolderPath
Application.ScreenUpdating = False
'On Error GoTo NoFileSelected
selectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For iFileNum = LBound(selectedFiles) To UBound(selectedFiles)
strFileName = selectedFiles(iFileNum)
Set wk = Workbooks.Open(strFileName)
For Each sh In wk.Sheets
If sh.Name Like "DATA*" Then
With sh
iLastRowReport = .Range("D" & .Rows.Count).End(xlUp).Row
iNumberOfRowsToPaste = iLastRowReport + 2 - 1
'.Range("A3:AG" & iLastRowReport & " , AL3:EJ & iLastRowReport").Select
' Selection.Copy
Set MultiRng = Union(.Range("A3:AG" & iLastRowReport), .Range("AL3:EJ" & iLastRowReport))
'you delete the 3 in range ("AL:EJ....) that make your code not work.
MultiRng.Copy
With master
iCurrentLastRow = .Range("B" & .Rows.Count).End(xlUp).Row
iRowStartToPaste = iCurrentLastRow + 1
'.Activate ' <-- not needed
.Range("A" & iRowStartToPaste).PasteSpecial xlPasteAll
'ActiveSheet.Paste <-- not needed
End With
End With
End If
Next sh
wk.Close
Next
getSpeed (False)
Application.ScreenUpdating = True
NoFileSelected:
End Sub