I'm trying to lookup values from Master Data worksheet check if "CONDITION 1" is true and to populate with "Value" each column with header "SITE # 1" in Project Visit worksheet having empty row using VBA.
Note that number of row and columns will remain variable, hence I'm want to use .UsedRange to cut down unnecessary loops.
Screenshots
Code
Private Sub CommandButton1_Click()
Set rng1 = Range("b3")
On Error Resume Next
Dim P_Row As Long
Dim P_Clm As Long
Table1 = Sheet2.Range("A:A") ' LOOKUP VALUE
Table2 = Sheet1.Range("A:B") ' Range of LOOKUP VECTOR
Dept_Row = Sheet2.Range(rng1.Address).Row ' CURRENT DUE FOR THE MONTH
Dept_Clm = Sheet2.Range(rng1.Address).Column
For Each cl In Table1
Sheet2.Cells(P_Row, P_Clm) = Application.WorksheetFunction.VLookup(cl, Table2, 2, False)
Dept_Row = P_Row + 1
Next cl
End Sub
Related
I have a worksheet with a table with several data. I need to copy filtered data to a word document.
First I've tried with .copy in excel and .pastespecial in word but after reading a lot during this last 4 days I started to work directly with objects because copy/paste procedure was slow and also it didn't get the results that I want.
With Object method I've found that when the range with specialCells(xCellTypeVisible) has multiple areas you need to look in every area to get the count of rows. But for some reason a row is added in Range but this row is not showed in Filter.
The code filters in a table Called "Horas" in a sheet called "Horas" by an string in Column A and an array on Column D (column D could have the following values V, W, X, Y and Z)
When filter by Column A and then filter by Array (X,Y and Z) some rows filtered with column A with values other than X Y and Z are inside of Range and not filtered.
This is part of the code
'code to set word app, word doc and set XLSDoc objects, etc
Set xlsSheet = xlsDoc.Worksheets("Horas")
xlsSheet.Activate
' Clear AutoFilter
For nCounter = 1 To xlsSheet.ListObjects("Horas").ListColumns.Count
xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=nCounter
Next
' Filter by customer and Row Type
xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=1, Criteria1:=customer
xlsSheet.ListObjects("Horas").Range.AutoFilter Field:=4, Criteria1:=Array("X", "Y", "Z"), Operator:=xlFilterValues
' calculate las row in table
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row - 1
Dim rngFiltered As Range
Set rngFiltered = Nothing
On Error Resume Next
'define range with cells visible in table
Set rngFiltered = Range("B2:G" & LR).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' check if range return values
If Not rngFiltered Is Nothing Then
Dim lcount
Dim rngArea
'check every area in range to get row count
For Each rngArea In rngFiltered.SpecialCells(xlCellTypeVisible).Areas
lcount = lcount + rngArea.Rows.Count
Next
Dim i As Long
'Add a row in word Table for every row in range filtered with visible cells
For i = 1 To lcount
HourTable.Rows.Add
Set oRow = HourTable.Rows(HourTable.Rows.Count)
Dim z As Long
For z = 1 To 6
'Copy every cell to word document
oRow.Cells(z).Range.Text = rngFiltered.Cells(i, z))
Else
'code to add a row if range is empty
HourTable.Rows.Add
Set oRow = HourTable.Rows(HourTable.Rows.Count)
Dim mergeRNG As Word.Range
Set mergeRNG = oRow.Cells(1).Range
mergeRNG.End = oRow.Cells(HourTable.Columns.Count).Range.End
mergeRNG.Cells.Merge
HourTable.Cell(HourTable.Rows.Count, 1).Range.Text = "No se registraron horas en el período"
End If
This code correctly filter by customer but when the customer has some rows with values other than X Y and Z still appears in range and are copied to Word Table.
I think I have the same problem of this Thread but in this thread, data appears in the same area in continous rows. In my case, several rows are filtered when Column D filter is applied.
Thanks in advance for reading. Please forgive my english writing.
oRow.Cells(z).Range.Text = rngFiltered.Cells(i, z)
You can't access a multi-area (noncontiguous) range using an index like this.
To illustrate:
Sub Tester()
Dim rngVis As Range, rw As Range, i As Long
'rows 2:3 and 5 are hidden
Set rngVis = ActiveSheet.Range("A1:C6").SpecialCells(xlCellTypeVisible)
Debug.Print rngVis.Address(False, False) '>> A1:C1,A4:C4,A6:C6
Debug.Print rngVis.Cells(1, 1).Address(False, False) '>> A1
Debug.Print rngVis.Cells(2, 1).Address(False, False) '>> A2 ! Cannot access range this way
'loop rows like this, not using a counter.
For Each rw In rngVis.Rows
i = i + 1
Debug.Print i, rw.Address(False, False)
Next rw
'Output:
'1 A1:C1
'2 A4:C4
'3 A6:C6
End Sub
I want to create a macro contains couple of column values need to get update when we click the button.
Sub replaceBlank()
Dim rng As Range
Selection.Value = Selection.Value
For Each rng In Selection
If rng = "" Or rng = " " Then
rng.Value = "0"
Else
End If
Next rng
End Sub
With this sample code I can only select the columns and execute. Instead, is there any possibility to change with list of column names then can we execute?
Let me know if you want to create the table programmatically. But for now we will proceed with the manual technique.
I'm using Excel 2016...First select the entire data set. Go to the [Insert] menu and select [Table]. Click anywhere inside the new table and the [Table Tools -> Design] menu will appear at the end of the ribbon. Go in there and take note of the [Table Name] field as you will need it in the code below to properly set the objList variable.
The column names are hard coded to an array but you can load a Listbox with column names a hidden sheet and get really fancy with it if you like:
Sub replaceBlank()
Dim rngRow As Range, rngColDataSet As Range
Dim ws As Worksheet
Dim objListCols As ListColumns
Dim objList As ListObject
Dim cntCols As Long, y As Long, MaxCols As Long
Dim arColNames(1) As String
'add column names as needed
arColNames(0) = "Revenue"
arColNames(1) = "Margin"
Set ws = ActiveSheet 'because ActiveSheet won't list properties/methods and that just bugs me
Set objList = ws.ListObjects("Table1")
Set objListCols = objList.ListColumns
MaxCols = objListCols.Count
'--> loop each column in the table
For cntCols = 1 To MaxCols
'--> test if column is in the names you want processed
For y = LBound(arColNames) To UBound(arColNames)
If arColNames(y) = objListCols(cntCols).Name Then
Set rngColDataSet = objListCols(cntCols).DataBodyRange.Areas(1)
'-----------> OPTION 1: QUICK AND EFFICIENT!
rngColDataSet.Replace "", "0", xlWhole
rngColDataSet.Replace " ", "0", xlWhole
'-----------> OPTION 2: IF YOU WANT TO ACCESS INDIVIDUAL CELL PROPERTIES OR METHODS <-------------------
' For Each rngRow In rngColDataSet
' If rngRow.Value = "" Or rngRow.Value = " " Then
' rngRow.Value = "0"
' End If
' Next
Exit For
End If
Next
Next
End Sub
Thanks to #Zack E and #JvdV for the inspiration ;)
I have several sheets with different structure that i need to merge using some of the columns headers that are common
I gathered in the one sheet ("Combine") the common headers and tried to write a macro to find the same column and to its data to the combine sheet, the macro is only getting the first column and not proceeding.
Any guidance with this issue will be appreciated
Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Sht As Worksheet ' Every Sheet on This Workbook
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
II = 2 ' Start on row 2 - Sheet1 & Sheet2
XX = 2 ' Start on row 2 - Combine sheet
'Looping through the worksheets in the workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
For ZZ = 1 To 100
For I = 1 To 100
If Sheets(Sht.Name).Cells(1, I).Value = Comb.Cells(1, ZZ).Value Then
Do Until IsEmpty(Sht.Columns(1).Cells(II))
Comb.Cells(XX, ZZ).Value = Sheets(Sht.Name).Cells(II, I).Value
II = II + 1
XX = XX + 1
Loop
End If
Next I
I = 1
Next ZZ
End If
II = 2 ' Reset 1st Loop to capture the new sheet data
Next
If I understand your question correctly, you have multiple sheets that have a heading row of some number of columns. You then have data rows below this in corresponding columns.
You’ve looked at the headings in each sheet and added those names that are common to a sheet you’ve called Combine. Not all columns on all sheets are found on the Combine sheet. The Combine sheet is a subset of the total column names in the workbook.
The sheets might contain data from several test runs or whatever. The output might contain common columns as well as some additional data. For example, sheet 1 could contain date, time, location, and result. Sheet 2 could contain date, time, and tester.
You want a combined sheet that shows the common fields, in this case Date, Time, Result, and Tester. You’ve already determined the common headings.
I think your problem might be in Do Until IsEmpty(Sht.Columns(1).Cells(II)). You may be encountering an empty cell.
Also, it is much faster to use Excel's built-in functions to perform moving large blocks of data between sheets.
Given you seem to be learning about VBA and have made a pretty good attempt, I took the liberty to provide you with an example that uses a more advanced way for solving the problem
The code below in effect concatenates the data from each sheet and common column on to the Combine sheet. It leaves blanks where a column does not have a data sheet have data that would be copied into the Combine column. This means that there will be blank cells under the columns Result and Test – based on the source data sheet.
I hope you find this helpful and that it answers your question. I have learned a lot from other's example on this site and am trying to pay it forward.
Option Explicit
Public Sub Tester()
'Not needed
'Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
'Declare a range object and assign it to contain column names
'from Combine. This range, converted to a list
'below will compare the combined heading names with
'each column heading on each sheet.
Dim rngCombineHeadings As Range
'set combine headings into the range using the function
'EndOfRangeColumn, which is decribed below
Set rngCombineHeadings = EndOfRangeColumn(Comb.Range("A1"))
'Declare a collection to be used in the for loop to compare
'Combine column headings with each source sheets headings
'Only copy those columns that match
Dim colCombinedHeadings As Collection
'Get a collection (aka list of strings) of the column headings
Set colCombinedHeadings = GetCommonHeadings(rngCombineHeadings)
'Declare two ranges to be used as the index inside
'for loops below.
Dim combineColTargetRng As Range
Dim colRng As Range
'Declare a variant to used use the index for looing
'through the Combine sheet headings
Dim vHeading As Variant
'Declare tblRng. It will be set to contain the entire data table
'on each sheet. Row 1 contains the headings, rows 2 - n contain
'the data that may be moved.
Dim tblRng As Range
'This is the range that will be manipulated and copied
'to the Combine sheet
Dim copyRng As Range
'Looping through the worksheets in the workbook
'Index variable used in for each loop below best practice is
'declare you variables near where they are used.
Dim Sht As Worksheet ' Every Sheet on This Workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
'Set the data table to the tblRng object.
Set tblRng = EndOfRangeRow(Sht.Range("A1"))
Set tblRng = EndOfRangeColumn(tblRng)
'For each sheet, loop through each headings on
'the Combined sheet and compare those to the
'headings on the data table on the current sheet
For Each vHeading In colCombinedHeadings
For Each colRng In tblRng.Columns
'if the heading on Combined = the current
'columns heading then, copy the data
'to the combined sheet.
If vHeading = colRng.Value2(1, 1) Then
'Resize the copy range to exclude the heading row
'and to reduce the size by one row, reflecting removal
'of the header row from the range
Set copyRng = ResizeTheRange(colRng.Offset(1, 0))
'Find the column on the Combine sheet that
'matches the current value in vHeading
Set combineColTargetRng = rngCombineHeadings.Find(colRng.Value2(1, 1))
'Copy the current sheet-current column to the clipboard
copyRng.Copy
'The if statement below determines if this is the first
'column of data being copied to the Combine sheet
'if it is, the row 2 current column is empty
'otherwise it has a value and we need to move the paste point
'to the end of the current Combine sheet column
If combineColTargetRng.Offset(1, 0).Value2 = "" Then
Set combineColTargetRng = combineColTargetRng.Offset(1, 0)
Else
Set combineColTargetRng = EndOfRangeRow(combineColTargetRng)
Set combineColTargetRng = _
combineColTargetRng.Offset( _
combineColTargetRng.Rows.Count, 0)
End If
'Paste the values copied from the current sheet
'that are under the same column heading as on the combined sheet
'There are a number of options for pasteSpecial
'See https://learn.microsoft.com/en-us/office/vba/api/excel.range.pastespecial
combineColTargetRng.PasteSpecial Paste:=xlPasteAll
End If
Next
Next
End If
Next
End Sub
'*****************************************************************************
'**
'** This function demonstrates use of the ParamArray. It enables the
'** calling routine, to provide the range as an Excel Range, a Collection
'** an Array, or a list of strings.
'**
'** Calling the Function:
'** Dim aCol as Collection
'** Set aCol = GetCommonHeadings(aCol)
'** Dim rngExcelRange as Range
'** set rngExcelRange = Range("A1:X1")
'** Set aCol = GetCommonHeadings(rngExcelRange)
'** Dim vArr() as Variant
'** vArr = Array("H1", "H2", "H3", "H4")
'** Set aCol = GetCommonHeadings(vArr)
'** Set aCol = GetCommonHeadings("Title1", "Title2", "Title3", "Title4")
Public Function GetCommonHeadings(ParamArray mRange() As Variant) As Collection
'Instantiate the return collection
Dim retVal As New Collection
Dim nDx As Long
If UBound(mRange) < 0 Then
'Cannot do anything without the heading range
Set retVal = Nothing
ElseIf TypeOf mRange(0) Is Range Then
'Heading Range is an Excel Range
Dim rngMaster As Range
Dim colRng As Range
Set rngMaster = mRange(0)
For Each colRng In rngMaster.Columns
retVal.Add colRng.Value2
Next
ElseIf TypeOf mRange(0) Is Collection Then
'Heading Range is a collection of text strings
Set retVal = mRange(0)
ElseIf VarType(mRange(0)) = vbArray + vbVariant Then
'Heading Range passed is an array of strings
Dim varArr() As Variant
varArr = mRange(0)
For nDx = 0 To UBound(varArr)
retVal.Add varArr(nDx)
Next
ElseIf VarType(mRange(0)) = vbString Then
'mRange contains an array of strings
For nDx = 0 To UBound(mRange)
retVal.Add mRange(nDx)
Next
Else
Set retVal = Nothing
End If
Set GetCommonHeadings = retVal
End Function
'****************************************************************************
'**
'** The Functions EndOfRangeColumn, EndOfRangeRow, StartOfRangeColumn, and
'** StartOfRangeRow take one parameter which is an Excel Range. Based on
'** the funtions name it will return the cell that is at the other end.
'** These are just wrappers to make the code more readable. The real work
'** is done by the Private Function GetRangeAtEnd. The private function
'** takes an Excel Range and the direction you want to move.
Public Function EndOfRangeColumn(ByRef mStartOfRange As Range) As Range
Set EndOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToRight)
End Function
Public Function EndOfRangeRow(ByRef mStartOfRange As Range) As Range
Set EndOfRangeRow = GetRangeAtEnd(mStartOfRange, xlDown)
End Function
Public Function StartOfRangeColumn(ByRef mEndOfRange As Range) As Range
Set StartOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToLeft)
End Function
Public Function StartOfRangeRow(ByRef mEndOfRange As Range) As Range
Set StartOfRangeRow = GetRangeAtEnd(mStartOfRange, xlUp)
End Function
Private Function GetRangeAtEnd(ByRef mRange As Range, ByVal mDirection As XlDirection) As Range
Set GetRangeAtEnd = Range(mRange, mRange.End(mDirection))
End Function
'***************************************************************
'**
'** The Private Function ResizeTheRange takes an Excel range
'** provide in the parameter. In effect it removes the first
'** row from the provided range, and reduces the size by one.
Private Function ResizeTheRange(ByRef mRange As Range) As Range
Dim retVal As Range
Set retVal = mRange.Offset(1, 0)
Set retVal = retVal.Resize(retVal.Rows.Count - 1, 1)
Set retVal = EndOfRangeRow(retVal)
Set ResizeTheRange = retVal
End Function
Goal
I would like to loop through five sheets and populate a dropdown list in a sixth sheet based on some requirements.
Problem
I don't know how to populate the dropdown list, make them dynamic and loop through the five sheets.
Description
In the sixth sheet (Dropdown Sheet), column E contains names which I would like to compare to the first row (E1:GG1) in the five sheets. Each column has a bunch of 1's.
If there is a match between a name in column E (Dropdown Sheet) and a name in a row (one of the five sheets) AND there's a '1' in the column for that row, the dropdown list should be populated with the ID in column A.
Desired output
Code
Private Sub ValuesInDropdownList()
Dim TeamSource As Range, PersonSource As Range, r As Range, csString As String
Dim PersonCell As Range, TeamCell As Range
Dim Dropdown As Collection
Dim i As Integer
Dim lastRow As Integer
Set TeamSource = Sheets("Dropdown Sheet").Range("E10:E100")
Set PersonSource = Sheets("Sheet1").Range("E1:GG1")
Set Dropdown = New Collection
On Error Resume Next
For Each PersonCell In PersonSource
v = PersonCell.Value
Debug.Print (v)
With PersonSource
lastRow = .Cells(.Rows.Count, PersonCell.Columns.Count).End(xlUp).Row
Debug.Print (lastRow)
End With
If v <> "" Then
For Each TeamCell In TeamSource
Debug.Print (TeamCell)
If PersonCell = TeamCell Then
intValueToFind = 1
For i = 1 To lastRow
If PersonCell.Offset(i, 0) = intValueToFind Then
Debug.Print (PersonCell.Offset(i, -4))
Dropdown.Add v, CStr(v)
End If
Next i
End If
Next TeamCell
End If
Next PersonCell
End Sub
I have two sheets say (Sheet1)=Sheets("Jan") and sheet2=Sheets("Feb")
I want to copy only that data from range b5:b81 from sheets ("Jan") to sheets("Feb") if it meets the condition in range AN5:AN81.
I am using this code but not working
Sub CopyRows()
Dim Rng As Range
Dim Rng2 As Range
Dim Cl As Range
Dim str As String
Dim RowUpdCrnt As Long
Set Rng = Sheets("Jan").UsedRange 'the range to search ie the used range
Set Rng2 = Sheets("Jan").Range("B")
str = "WRK." 'string to look for
Sheets("Feb").Range("B5:B81").Value = ""
RowUpdCrnt = 5
' In my test data, the "Yes"s are in column AN. This For-Each only selects column AN.
' I assume all your "Yes"s are in a single column. Replace "B" by the appropriate
' column letter for your data.
For Each Cl In Rng.Columns("AN").Rows
If Cl.Text = str Then
'if the cell contains the correct value copy it to next empty row on sheet 2 & delete the row
Cl.cell(2, 5).Copy Sheets("Feb").Cells(RowUpdCrnt, 1)
RowUpdCrnt = RowUpdCrnt + 1
End If
Next Cl
End Sub