I would like to write a VBA macro for excel through which i want data from a master sheet to populated to another sheets conditionally.
for example, my master sheet ("Sheet1) has multiple rows and column. The condition for data population from Sheet1 to Sheet2 should be based on these condition
(1) Only rows which has a particular string in a column (say "keyword" string in column D)
(2) Only few columns to be copied from Sheet1 to Sheet2 (say column A,B,E & G)
I have a code that copies a column when the heading of the column is a certain string, would that help?
Edit1:
Here is what I have come up with. The code should be flexible enough to adapt to any type of spreadsheet you've got
Dim keyColumn As Integer
Dim i As Integer
Dim keyWord As Variant 'I've used variant, so you can choose your own data type for the keyword
Dim dataSh As String 'I'm using sheet names for sheet referencing
Dim populateSh As String
Dim rowNum As Integer
Dim dataRow() As Variant
Sub Populate()
'set the column number, which contains the keywords, the keyword itself,
'name of the sheet to populate and the row offset you'd like to start populating
populateSh = "populate"
keyColumn = 4
keyWord = "yes"
rowNum = 0
'assuming you run the macro in the sheet you get the data from, get its name to return to it after copying the row
dataSh = ActiveSheet.Name
'loop through all the used cells in the column
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, keyColumn) = keyWord Then
'starting in row 1 in the sheet you populate, you'll have to set the rowNum variable to desired offset few lines above
rowNum = rowNum + 1
Call copyRow(i, rowNum)
End If
Next i
End Sub
Sub copyRow(ByVal cRow As Integer, ByVal pRow As Integer)
Dim colNum As Integer
'set the number of columns you'd like to copy
colNum = 3
'redimension the array to carry the data to other sheet
'this can be done any way you,d like, but I'm using array for flexibility
ReDim dataRow(1 To colNum)
'put the data into the array, as an example I'm using columns 1, 2 and 3, while skipping the keyword column.
dataRow(1) = Cells(cRow, 1)
dataRow(2) = Cells(cRow, 2)
dataRow(3) = Cells(cRow, 3)
Sheets(populateSh).Select
For p = 1 To UBound(dataRow)
Cells(pRow, p) = dataRow(p)
Next p
Sheets(dataSh).Select
End Sub
Hope that helps. Sorry for any style errors in advance
Related
I'm wondering if its possible to create a VBA that map a random "numerical codes" from an excel Spreadsheet 2 (let's say column A) to a column B (Spreadsheet 1).
Some of the values on the spreadsheet 2 are repeated, I would like to build a unique correspondence (no repeated values from column A / Spreadsheet 2 to my column B / Spreadsheet 1)
Spreadsheet1:
Spreadsheet2
Desired output, column filled from Spreadsheet2 (Unique)values :
Is this possible?? feasible??
The following VBA code uses for loops to iterate through the list of values in Spreadsheet2 and only copy each value to Spreadsheet1 if the value has not occurred already in the list.
Option Explicit
Sub ListUniqueCodes()
Dim code As Long
Dim codes As Range
Dim i As Integer
Dim j As Integer
Dim last_row As Integer
Dim output_cell As Range
Dim unique_codes As New Collection 'You could also use a Scripting.Dictionary here as suggested by JvdV
'See https://stackoverflow.com/questions/18799590/avoid-duplicate-values-in-collection
'Store the length of the list of codes that is in Spreadsheet2:
last_row = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1").End(xlDown).Row
'Store the list of codes that is in Spreadsheet2:
Set codes = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1:A" & last_row)
'For each code...
For i = 1 To codes.Rows.Count
code = codes.Cells(i).Value2
'...if it does not equal zero...
If code <> 0 Then
'...and if it is not already in the collection unique_codes...
For j = 1 To unique_codes.Count
If unique_codes(j) = code Then Exit For
Next j
'...then add it to the collection unique_codes:
If j = (unique_codes.Count + 1) Then
unique_codes.Add code
End If
End If
Next i
Set output_cell = Workbooks("Spreadsheet1.xlsm").Sheets("Sheet1").Range("B2")
'Write out the unique codes in Spreadsheet1:
For i = 1 To unique_codes.Count
output_cell.Offset(i - 1, 0).Value2 = unique_codes(i)
Next i
End Sub
I working on a sheet that looking up the value in column D and compares that value to another sheet in another workbook to see if it is in there as well. If the value is in the other sheet then the loop moves to the next cell in column D. If it is not, then I want to highlight the row of which that value is located but only the cells that contain information (A:CU). I cannot seem to get it right.
The code I have so far highlights the row of the cell where the value was not found in the other sheet. The problem is it highlights the entire row. I know this is because of the .EntireRow but I am not sure how to only highlight the the cells I need.
Sub check()
Dim i As Integer
Dim k As Integer
Dim j As Integer
Dim Sheet1 As Worksheet
Dim WorkingTab As Worksheet
Dim PerDay24 As Workbook
Dim CurrentOrderCalendar As Workbook
Set Sheet1 = Worksheets("Sheet1")
Set PerDay24 = Sheet1.Parent
Set CurrentOrderCalendar = Workbooks.Open("M:\Projects\D9#s Purging\Current Order Calendar - Copy.xlsx")
Set WorkingTab = Worksheets("working tab")
k = Sheet1.UsedRange.Rows.Count
j = WorkingTab.UsedRange.Rows.Count
For i = 2 To k
If Application.WorksheetFunction.CountIf(WorkingTab.Range(WorkingTab.Cells(2, 1), WorkingTab.Cells(j, 1)), Sheet1.Cells(i, 4).Value) > 0 Then
Sheet1.Cells(i, 100).Value = "Active"
Else
Sheet1.Rows(i).EntireRow.Interior.Color = 65535
End If
Next i
End Sub
I expect for the code to highlight columns A:CU on row i when the IF statement is false.
Is there a method to swap/switch data automatically in Excel?
For example:
I have an Excel sheet of almost 16.000 columns. Each column has 5 rows. The 5 rows contain information such as A,B,C,D,E but the data is not sorted, so I have the following: B,A,C,D,E or B,C,D,E.
I want to put all As first and the rows that do not contain an A so (B,C,D,E) to add a blank row before B.
I have only found how to do it manually and with less data and columns.
You can do this using a formula (fill down and then across):
Based on your comment, this below code should work for the 3 items you listed. If you have more options, just update the fields in the arrays
Sub CFixer()
Dim c As Long, WS As Worksheet, i As Integer, startRow As Integer, lastRow As Long, checkRNG As Range
Dim Check(2) As String 'must match below list
Check(0) = "BAC"
Check(1) = "GLO"
Check(2) = "HDP"
Dim T(2) As String ' must match list above
startRow = 1 'first row to evaluate
Set WS = ActiveSheet
lastRow = startRow + UBound(Check) 'last row to look to replace
For c = 1 To WS.UsedRange.Columns.Count
Set checkRNG = Range(WS.Cells(startRow, c), WS.Cells(lastRow, c))
For i = 0 To UBound(Check)
If Application.WorksheetFunction.CountIf(checkRNG, Check(i)) > 0 Then
T(i) = Check(i)
Else
T(i) = ""
End If
Next i
checkRNG.Value = Application.WorksheetFunction.Transpose(T)
Next c
End Sub
This will change rows as shown:
CORRECTED After Picture:
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
Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function