excel code to print multiple sheets based on formula - excel

I have to print multiple sheets in excel based on whether that sheet is relevant to a user or not. In a sheet called "Sheet2" I have in column A from cell 14, the sheet names. There are 24 sheets with different names in Column A. In each adjacent cell (in Column B), I have either True or False. I wish to print the sheets which have a True in column B. I am able to print to the sheets one by one and not all the relevant sheets simultaneously as one file. The code I use is as follows:
Sub CommandButton1_Click()
Dim wb As Workbook
Dim SheetsToPrint As String
Set wb = ThisWorkbook
Dim sheetWithData As Worksheet
Set sheetWithData = wb.Sheets("Sheet2")
Dim startNameRange, endNameRange As Integer
startNameRange = 14
endNameRange = 39
For i = startNameRange To endNameRange Step 1
Dim nameSheetToPrint As String
SheetsToPrint = sheetWithData.Range("A" & i).Value
Dim wsToPrint As Worksheet
Set wsToPrint = wb.Sheets(SheetsToPrint)
If sheetWithData.Cells(i, 2) = "True" Then
wsToPrint.PrintOut From:=1, To:=1
End If
Next i
End Sub

Adapt the vars and try this :
Sub PrintSheet()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim sheetWithData As Worksheet
Set sheetWithData = wb.Sheets("Sheet2")
'Add the first row number and the last row number where start the sheet name
Dim startNameRange, endNameRange As Integer
startNameRange = 2
endNameRange = 4
For i = 2 To 4 Step 1
Dim nameSheetToPrint As String
nameSheetToPrint = sheetWithData.Range("A" & i).Value
Dim wsToPrint As Worksheet
Set wsToPrint = wb.Sheets(nameSheetToPrint)
If sheetWithData.Cells(i, 2) = "True" Then
wsToPrint.PrintOut
End If
Next i
End Sub

Related

Select Subset of Range in VBA based on value

I am trying to select a subset of data in a range and copy it to another sheet in Excel. My thought process was as follows
Find the first and last instance of the value in a column
Copy from the first instance down to the last instance and all the way to the Right
Paste the range of data into my sheet
I am having trouble finding the first and last instance of the value in a column and setting the range to copy.
This is what I have so far:
Sub Button()
'Application.ScreenUpdating = False
Dim wb As Workbook
Dim ws_temp, ws_data As Worksheet
Dim data_rng As Range
Set wb = ThisWorkbook
Set ws_temp = wb.Sheets("Template")
Set ws_data = wb.Sheets("data")
'declare id
Dim id As Integer
Set id= ws_temp.Range("B4").Value 'this is where the value is stored
'find first instance of id in data.
' The data starts in cell A6 and extends to column O. The number of rows will be variable
'find last instance of pitcher id
'Set data_rng
Set data_rng = wb.ws_data.Range("first instance":O&"second instance")
'Copy data_rng
data_rng.Copy wb.ws_temp.Range("A8") 'the data will always go in cell A8 on the Template sheet
'Application.ScreenUpdating = True
End Sub
What you could do is use Application.Match to find the row of the first instance then use Application.CountIf to count the no of occurrences of the search term.
With that information you should be able to get the subset of the data you want to copy using Resize.
Sub Button()
Dim wb As Workbook
Dim ws_temp, ws_data As Worksheet
Dim data_rng As Range
Dim id As Long
Dim lngFirstRow As Long
Dim lngNoRows As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws_temp = wb.Sheets("Template")
Set ws_data = wb.Sheets("data")
' get search id
id = ws_temp.Range("B4").Value
' find row of first occurence of id
lngFirstRow = Application.Match(id, ws_data.Columns(2), 0)
' find count of id
lngNoRows = Application.CountIf(ws_data.Columns(2), id)
Set data_rng = ws_data.Range("B" & lngFirstRow).Resize(lngNoRows, 14)
'Copy data_rng
data_rng.Copy ws_temp.Range("A8") 'the data will always go in cell A8 on the Template sheet
Application.ScreenUpdating = True
End Sub

Copy data from another workbook without hardcoding the file path

I am trying to copy and transpose data from one workbook to another. Each week the file to copy information from is updated to a new workbook. In my macro I callout "Week of 06-17-19 WGN WB A-line.xlsm".
I would like to manually open the sheet to copy the data without having to hard-code the new date.
Could I use the ActiveWorkbook function to call the new open sheet?
Sub copytranspose()
Application.ScreenUpdating = False
Dim i As Integer
Dim Column As Integer
Dim Row As Integer
Row = 5
Column = 8
For i = 1 To 6
Workbooks("Week of 06-17-19 WGN WB A-line.xlsm").Worksheets("WEEKLY").Cells(10, Column).Copy
Column = Column + 2
Workbooks("copy transpose.xlsm").Worksheets("sheet1").Cells(Row,3).PasteSpecial Paste:=xlPasteValues
Row = Row + 1
Next i
End Sub
Solution 1
You can avoid hard-coding in the date into the code by storing the date of the file you want to open in a cell. Say you have a sheet called "config" and in range "A1" you have the date "06-24-19". Assuming you have both files in the same directory you could write something like this
Dim i As Integer
Dim Column As Integer
Dim Row As Integer
Row = 5
Column = 8
Dim currFileDate As String
currFileDate = Format(ThisWorkbook.Worksheets("Config").Range("A1").Value, "mm-dd-yy") '' Get the date typed in
Dim srcDataWB As Workbook
'' Open the workbook automatically with the file date of A1
Set srcDataWB = Workbooks.Open(ThisWorkbook.Path & "\Week of " & currFileDate & " WGN WB A-Line.xlsm")
For i = 1 To 6
srcDataWB.Worksheets("WEEKLY").Cells(10, Column).Copy
Column = Column + 2
'' If this is the same workbook that the code is stored
'' I suggest switching out Workbooks("copy transpose.xlsm") for ThisWorkbook
Workbooks("copy transpose.xlsm").Worksheets("sheet1").Cells(Row, 3).PasteSpecial Paste:=xlPasteValues
Row = Row + 1
Next i
Solution 2
Alternatively, if what you really want is to just match an already opened workbook that matches the pattern of "Week of * WGN WB A-line.xlsm" then the following will work. HOWEVER it's not bullet-proof since you could potentially have two workbooks open that match that pattern.
Sub DoStuff()
Dim i As Integer
Dim Column As Integer
Dim Row As Integer
Row = 5
Column = 8
Dim srcDataWB As Workbook
'' Get the already opened workbook that matches the pattern 'Week of * WGN WB A-line.xlsm'
Set srcDataWB = GetSrcDataWB
For i = 1 To 6
srcDataWB.Worksheets("WEEKLY").Cells(10, Column).Copy
Column = Column + 2
'' If this is the same workbook that the code is stored
'' I suggest switching out Workbooks("copy transpose.xlsm") for ThisWorkbook
Workbooks("copy transpose.xlsm").Worksheets("sheet1").Cells(Row, 3).PasteSpecial Paste:=xlPasteValues
Row = Row + 1
Next i
End Sub
Function GetSrcDataWB() As Workbook
Dim wbName As String
Dim currWB As Workbook
For Each currWB In Application.Workbooks
If currWB.name Like "Week of * WGN WB A-line.xlsm" Then
Set GetSrcDataWB = currWB
Exit For '' No more need to loop
End If
Next
End Function

Copy a row of only data then move on to the next worksheet if no values left

I don't know how to create this section of the code. This is a template code that I've used to copy specific values from a cell from each worksheet into one master worksheet that compiles that data usually into one row.
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer
Set destsh = ActiveWorkbook.Worksheets.Add
destsh.Name = "Master"
i = 1
For Each sh In ActiveWorkbook.Worksheets
***destsh.Cells(i, 1).Value = sh.Range("B7:B90").SpecialCells(xlCellTypeConstants).Select***
i = i + 1
Next
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
End Sub
I want my code to go through each worksheet in my workbook and copy the column from the range B7:B90 and stop where there are no more values within each row of each worksheet, then moves on to the next worksheet. Some worksheets have 10 cells in one row, others have 60; in this scenario my master file would show 70 cells in column A from both worksheets. The code creates a master worksheet that compiles the worksheets row B in one column.
The section I need help with has been asterisked
Your code creates the Master sheet every time which will cause the program to fail when it tries to name the sheet in the next run. Also, in your iteration through all sheets, you are reading data from Master sheet as well which might give incorrect results. I can quickly think of below code. I have used the numerical notation for rows and cells. Also since the range is constant, i looped through the range that you specified
Sub distribute()
Dim sh As Worksheet
Dim destsh As Worksheet
Dim i As Integer: i = 1
Dim sheetName As String: sheetName = ""
Set destsh = ActiveWorkbook.Worksheets.Add
'Taking sheet name as input from user
sheetName = InputBox("Enter sheetname to aggregate data")
'Checking if sheetname was entered properly
If (sheetName <> "") Then
destsh.Name = sheetName
ActiveWorkbook.Worksheets("Master").Cells.EntireColumn.ColumnWidth = 30
ActiveWorkbook.Worksheets("Master").Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Master").UsedRange.UnMerge
ActiveWorkbook.Worksheets("Master").UsedRange.WrapText = False
masterSheetRow = 1
For Each sh In ActiveWorkbook.Worksheets
'Making sure that the sheet is not the master sheet while getting rows
If (sh.Name <> sheetName) Then
For i = 7 To 90
If (sh.Cells(i, 2).Value <> "") Then
destsh.Cells(masterSheetRow, 1).Value = sh.Cells(i, 2).Value
masterSheetRow = masterSheetRow + 1
End If
Next
End If
Next
Else
MsgBox ("Enter valid sheetname")
End If
End Sub

Copy values to Workbook 1 (Main Workbook) from Workbook 2 when a cell value in Workbook 1 matches to column value in Workbook 2

I am working on a code to copy data to Workbook 1 (Main Workbook) from Workbook 2 based on a criteria.
The criteria is - If the value of cell C11 in Workbook 1 (Main Workbook) is equal to column A of Workbook 2, then copy all the data from Workbook 2 columns A to F to Workbook 1 (Main Workbook). Please note that there could be multiple matching values (in Workbook 2) that may need to be copied to Workbook 1.
I have tried the below code that pull all the data perfectly. Now I am trying to see if there is a code which can be applied to copy data based on criteria.
Private Sub CommandButton1_Click()
' Get Tiger calendar workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the Tiger calendar workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select the Tiger Calendar file"
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
' assume range is A1 - M10000 in sheet1
' copy data from Tiger calendar to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("Sheet1")
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)
targetSheet.Range("B14", "G500").Value = sourceSheet.Range("A2", "G500").Value
' Close customer workbook
customerWorkbook.Close
End Sub
For example, if Cell C11 in Workbook 1 = 1232223 (Product ID), then the data copied should be all the sales details related to the product ID. The bulk data is available in Workbook 2.
Who Is Who, What Is What
In this workbook check cell C11 against the values in source workbook's A column. When found, copy the range of the row and 6 contiguous columns (A-F) to this workbook starting from B14 (B-G). Do all of this until the last row of data in source workbook is reached.
Private Sub CommandButton1_Click()
Const filter As String = "Text files (*.xls*),*.xls*"
Const caption As String = "Please Select the Tiger Calendar file"
Const wsTarget As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTgtFirst As String = "B14" ' Target First Cell Range
Const cTgtSearch As String = "C11" ' Target Search Value Cell Range
Const wsSource As Variant = 1 ' Source Worksheet Name/Index
Const cSrcFirst As Long = 2 ' Source First Row
Const cSrcFirstCol As Variant = "A" ' Source First Column Letter/Number
Const cColumns As Integer = 6 ' Number of Columns
Dim customerFilename As String
Dim sourceSheet As Worksheet
Dim i As Long
Dim rngTarget As Range
customerFilename = Application.GetOpenFilename(filter, , caption)
Set sourceSheet = Workbooks.Open(customerFilename).Worksheets(wsSource)
With sourceSheet
Set rngTarget = ThisWorkbook.Worksheets(wsTarget).Range(cTgtFirst)
For i = cSrcFirst To .Cells(.Rows.Count, cSrcFirstCol).End(xlUp).Row
If .Cells(i, cSrcFirstCol) = rngTarget.Parent.Range(cTgtSearch) Then
.Cells(i, cSrcFirstCol).Resize(, cColumns).Copy _
rngTarget.Resize(, cColumns)
Set rngTarget = rngTarget.Offset(1, 0)
End If
Next
End With
sourceSheet.Parent.Close False
End Sub
You're going to want to add an If statement at the end. I havent tested this, but it should give you an idea of how to get this working.
'Your need to change this to what you need
Dim CustomerSheet = Customerworkbook.Worksheets("Sheet1")
If Customersheet.range("C11").value = targetSheet.range("A1").value then
targetSheet.Range("B14", "G500").Value = sourceSheet.Range("A2", "G500").Value
Else
Exit Sub
End If

Excel VBA - Copy cells based on criteria to another workbook saved in the same folder

I'm pretty new at this and I've gone through a ton of bundle of tutorials but I can't seem to grasp the concept of how to achieve this result in excel VBA. I'll try being as detailed as possible.
I have a folder with 3 x Excel files -
Script.xlsx (Just a button that holds the script/macro)
WhiteCrown.xlsx (the workbook I'd like to copy the data from)
PackCon.xlsx (the workbook I'd like the data pasted into)
Concept:
If Workbook ("WhiteCrown.xlsx") contains value in Column B5:B10000 which = Workbook ("PackCon.xlsx") Column B5:B10000 AND Workbook ("WhiteCrown.xlsx") contains a value in Column E
There are 2 cells I don't want the value of E copied - "soy-milk" "Pepsi-max"
The check is to be looped till column b
Reaches 10000
:) thanks in advance
Sub ConvertData()
Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngLookup As Range
Dim v
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\WhiteCrown.xlsx")
Set ws1 = wb1.Sheets("BOMQ")
Set wb2 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\PackCon.xlsx")
With wb2.Sheets("("BOMQ")")
Set rngLookup = .Range(.Cells(7, 2), _
.Cells(7, 2).End(xlDown)).Resize(, 3)
End With
With ws1
i = 7
Do Until .Cells(i, 2) = ""
v = Application.VLookup(.Cells(i, 2).Value, rngLookup, 3, False)
If Not IsError(v) Then .Cells(i, 4).Value = v
i = i + 1
Loop
End With
wb2.Close False
End Sub
*Script updated but still not working
I do not Understand what data you would like to copy. I have exhibited the logic to do so. Tested and working.
Option Explicit
Private Sub btnScript_Click()
Dim WhiteCrown As Workbook, PackCon As Workbook, DestWorkbook As Workbook
Dim SheetWhiteCrown As Worksheet, SheetPack As Worksheet
Dim RowIndex As Long
Dim RngWhite As Range
Dim RngWhiteCount As Long
Dim ValBWhite, ValBPack, ValEWhite As String
Application.ScreenUpdating = False
Set WhiteCrown = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\WhiteCrown.xlsx")
Set SheetWhiteCrown = WhiteCrown.Sheets("BOMQ")
Set RngWhite = SheetWhiteCrown.Range("RngWhiteData")
RngWhiteCount = SheetWhiteCrown.Range("RngWhiteData").Rows.Count + 5
Set PackCon = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\PackCon.xlsx")
Set SheetPack = PackCon.Sheets("BOMQ")
Set DestWorkbook = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\Script.xlsx")
For RowIndex = 5 To RngWhiteCount
ValBWhite = SheetWhiteCrown.Cells(RowIndex, "B").Value
ValBPack = SheetPack.Cells(RowIndex, "B").Value
ValEWhite = SheetWhiteCrown.Cells(RowIndex, "E").Value
If Not ValBWhite = "" And ValBWhite = "" Then
If Not ((ValEWhite = "SoyMilk") Or (ValEWhite = "Pepsi")) Then
'Perform your copy to Destworkbook or vlookup or anything
Else
'Do Nothing
End If
End If
Next RowIndex
WhiteCrown.Close
PackCon.Close
DestWorkbook.Close False
End Sub
Never use hardocode ranges like Range("B10:E60"). Best coding practise involved using named ranges as in the above code(example "RngWhiteData" is named range). Add error validations.
If you're satisfied please vote this answer.
Regards,
Mani

Resources