I want to copy a range of cells to another worksheet based on the criterion given in column N. So for each row it has to check whether or not it meets criterion in column N. If the value in Column N = 1, it should copy from that row Range(Cells(j, 1), Cells(j, 8)) to another worksheet starting at row 10. If the value in Column N = 0 it skips that row and checks the next one. So it doesn't copy that row.
Maybe my wrong code can explain it better than me:
Sub TCoutput()
Dim i As New Worksheet
Dim e As New Worksheet
Set i = ActiveWorkbook.Worksheet.Item(3)
Set e = ActiveWorkbook.Worksheets.Item(4)
Dim d
Dim j
d = 10
j = 3
Do Until IsEmpty(i.Range("N" & j))
If i.Range("N" & j) = "1" Then
d = d + 1
e.Range(Cells(d, 1), Cells(d, 8)) = i.Range(Cells(j, 1), Cells(j,8))
End If
j = j + 1
Loop
End Sub
When using multiple spreadsheets, you need to be careful and make sure all .Range and .Cells references include the worksheet you want to. First things first, replace your If statement with this one:
If i.Range("N" & j) = "1" Then
e.Range(e.Cells(d, 1), e.Cells(d, 8)) = i.Range(i.Cells(j, 1), i.Cells(j,8))
End If
Or, you can use With (which I personally prefer):
With i
If .Range("N" & j) = "1" Then
e.Range(e.Cells(d,1),e.Cells(d,8)) = .Range(.Cells(j,1),.Cells(j,8))
End If
End with
Without the explicit reference to a worksheet, the Cells() and Range() will defer to whichever one is the ActiveSheet.
try this. Ive add .value and d =d + 1
Sub TCoutput()
Dim i As New Worksheet
Dim e As New Worksheet
Set i = ActiveWorkbook.Worksheets.Item(1)
Set e = ActiveWorkbook.Worksheets.Item(2)
Dim d
Dim j
d = 10
j = 3
Do Until IsEmpty(i.Range("N" & j))
If i.Range("N" & j) = "1" Then
e.Range(e.Cells(d, 1), e.Cells(d, 8)).Value = i.Range(i.Cells(j, 1), i.Cells(j, 8)).Value
d = d + 1
End If
j = j + 1
Loop
End Sub
Related
So currently, per the title, I'm looking to make a smart and relatively automatic transpose system.
So far the only way I've figured out how to do this is with macros, paste special, and a lot of manual work (working on 2,000~ row sheet).
The following example is an example.
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
A Event 1
A Event 2
A Event 3
B Group 1
B Group 2
All the events belong to A1 but are distributed downwards in a new row. The goal is to have them all in a single row (either in a single cell or adjacent).
The example of how I need them is demonstrate below.
A Event 1 Event 2 Event 3
B Group 1 Group 2
I have searched far and wide and haven't found anything which solves this bizarre request.
You can do this quite easily using a dictionary. Have a look at the following. You will need to update the two With blocks with your input and destination range
Public Sub test()
Dim dict As Object
Dim arr As Variant, tmp As Variant
Dim i As Long
Dim key
Set dict = CreateObject("Scripting.Dictionary")
' Source Data
With Sheet1
arr = .Range(.Cells(1, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "B")).Value2
End With
For i = LBound(arr, 1) To UBound(arr, 1)
If Not IsEmpty(tmp) Then Erase tmp
If dict.exists(arr(i, 1)) Then
tmp = dict(arr(i, 1))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = arr(i, 2)
dict(arr(i, 1)) = tmp
Else
ReDim tmp(0)
tmp(LBound(tmp)) = arr(i, 2)
dict.Add key:=arr(i, 1), Item:=tmp
End If
Next i
' Destination
With Sheet1.Cells(1, 5)
i = 0
For Each key In dict.keys
.Offset(i, 0) = key
'' Side by side
Range(.Offset(i, 1), .Offset(i, UBound(dict(key)) + 1)).Value2 = dict(key)
'' In one cell
'.Offset(i, 1).Value2 = Join(dict(key), ",")
i = i + 1
Next key
End With
End Sub
Say we have data in columns A and B like:
Running this code:
Sub Macro1()
Dim Na As Long, Nd As Long, rc As Long
Dim i As Long, j As Long, K As Long
Dim v As Variant
Range("A:A").Copy Range("D:D")
Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
rc = Rows.Count
K = 5
Na = Cells(rc, "A").End(xlUp).Row
Nd = Cells(rc, "D").End(xlUp).Row
For i = 1 To Nd
v = Cells(i, "D")
For j = 1 To Na
If v = Cells(j, 1) Then
Cells(i, K) = Cells(j, 2)
K = K + 1
End If
Next j
K = 5
Next i
End Sub
will produce:
I am trying to make an auto scheduling program with an excel.
For example, each number is certain job assigned to the person given day.
1/2 1/3 1/4 1/5
Tom 1 2 2 ?
Justin 2 3 1 ?
Mary 3 3 ?
Sam 1 ?
Check O O X ? ## check is like =if(b2=c2,"O","X")
The things I want to make sure is every person is given a different job from yesterday.
My idea
while
randomly distribute jobs for 1/5
wend CheckCell = "O"
But I found that checking cell in the vba script doesn't work - the cell is not updated in each while loop.
Could you give me a little pointer for these kinds of program? Because I am new to vbaScript, any kinds of help would be appreciated.
Using VBA, I'm sure there are better ways to do this, but this will check the values from the penultimate column against values from last column and if they match it will write "O" to under the last column, else it will write "X":
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
counter = 0 'set counter
For i = 2 To LastRow 'loop through penultimate column and add values to array
If ws.Cells(i, LastCol - 1).Value <> "" Then
Values = Values & ws.Cells(i, LastCol - 1) & ","
End If
Next i
Values = Left(Values, Len(Values) - 1)
Values = Split(Values, ",") 'split values into array
For i = 2 To LastRow 'loop through last column and add values to array
If ws.Cells(i, LastCol).Value <> "" Then
ValuesCheck = ValuesCheck & ws.Cells(i, LastCol) & ","
End If
Next i
ValuesCheck = Left(ValuesCheck, Len(ValuesCheck) - 1)
ValuesCheck = Split(ValuesCheck, ",")
For y = LBound(Values) To UBound(Values) 'loop through both arrays to find all values match
For x = LBound(ValuesCheck) To UBound(ValuesCheck)
If Values(y) = ValuesCheck(x) Then counter = counter + 1
Next x
Next y
If counter = UBound(Values) + 1 Then 'if values match
ws.Cells(LastRow + 1, LastCol).Value = "O"
Else 'else write X
ws.Cells(LastRow + 1, LastCol).Value = "X"
End If
End Sub
just to clarify are you looking to implement the random number in the vba or the check.
To do the check the best way would be to set the area as a range and then check each using the cells(r,c) code, like below
Sub checker()
Dim rng As Range
Dim r As Integer, c As Integer
Set rng = Selection
For r = 1 To rng.Rows.Count
For c = 1 To rng.Columns.Count
If rng.Cells(r, c) = rng.Cells(r, c + 1) Then
rng.Cells(r, c).Interior.Color = RGB(255, 0, 0)
End If
Next c
Next r
End Sub
this macro with check the text you have selected for the issue and change the cell red if it matches the value to the right.
To make it work for you change set rng = selection to your range and change the rng.Cells(r, c).Interior.Color = RGB(255, 0, 0) to the action you want
A sligthly different approach than the other answers.
Add this function:
Function PickJob(AvailableJobs As String, AvoidJob As String)
Dim MaxTries As Integer
Dim RandomJob As String
Dim Jobs() As String
Jobs = Split(AvailableJobs, ",")
MaxTries = 100
Do
MaxTries = MaxTries - 1
If MaxTries = 0 Then
MsgBox "Could find fitting job"
End
End If
RandomJob = Jobs(Int((1 + UBound(Jobs)) * Rnd()))
Loop Until RandomJob <> AvoidJob
PickJob = RandomJob
End Function
And put this formula in your sheet
=PickJob("1,2,3",D2)
where D2 points to is the previous job
I have to create a Macro which lets me Concatenate two columns at a time in a given range. For example: In range C1:Z200, I want to concatenate Column C&D, E&F, G&H and so on. How do I do it. This is my current code which only concatenate first two columns..rest remains the same.
Set Range = ActiveSheet.Range("C1:Z100")
For Each c In Range
c.Select
ActiveCell.FormulaR1C1 = ActiveCell & " " & ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).Activate
Selection.Clear
ActiveCell.Offset(0, 2).Activate
Next c
Try this:
Sub Concat()
Dim i As Long, j As Long
For i = 1 To 100 'number of rows
j = 1 'reset column to 1
Do While j < 25 'max number of columns (until Column Y-Z)
j = j + 2 'start from third column (Column C)
Cells(i, j) = Cells(i, j) & " " & Cells(i, j + 1) 'concat
Cells(i, j + 1).ClearContents 'clear
Loop
Next i 'next row
End Sub
Try this:
Sub ConcatAltCellsInAltCols()
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet11")
Dim iLC As Long: iLC = oW.Cells(1, oW.Columns.Count).End(xlToLeft).Column
Dim iLR As Long: iLR = oW.Cells(oW.Rows.Count, 3).End(xlUp).Row
Dim iC As Long
Dim iR As Long
For iR = 1 To iLR
For iC = 3 To iLC Step 2
oW.Cells(iR, iC).Value = oW.Cells(iR, iC) & oW.Cells(iR, iC + 1)
Next
Next
End Sub
Try this using a one based array for better Performance:
Code
Option Explicit
Sub Conc()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Concat") ' <== change "Concat" to your sheet name to avoid subscript error
Dim v ' variant
Dim lng As Long
Dim j As Integer ' corr.
' use one based array to get field data
v = ws.Range("C1:Z100") ' your OP range
For lng = 1 To UBound(v)
' concatenate columns C&D, E&F, G&H, ...
For j = 0 To 11
v(lng, j * 2 + 1) = v(lng, j * 2 + 1) & v(lng, j * 2 + 2)
Next j
Next lng
' write array values back (overwriting D, F, H,... with the same values)
ws.Range("C1:Z100") = v ' your OP range
End Sub
I want to loop each number in column A through column B.
If there is a match, that number to be looped through column C.
If there is a match, I want the results to be returned in columns E and F.
Each column will have a variable amount of rows. There can also be multiple results.
In my example the number 1 from column A is looped through column B. If a match is found 1 is now looped through column C. If there is a match then columns E and F = C and D.
Example
If your data is arranged like bellow picture,then the code would be like this.
Sub test()
Dim vDB1, vDB2, vDB3, vR()
Dim i As Long, j As Long, k As Long, n As Long
vDB1 = Range("a2", Range("a" & Rows.Count).End(xlUp))
vDB2 = Range("b2", Range("b" & Rows.Count).End(xlUp))
vDB3 = Range("c2", Range("d" & Rows.Count).End(xlUp))
Range("e2:f2").Resize(Rows.Count - 1) = Empty
For i = 1 To UBound(vDB1, 1)
For j = 1 To UBound(vDB2, 1)
If vDB1(i, 1) = vDB2(j, 1) Then
For k = 1 To UBound(vDB3, 1)
If vDB1(i, 1) = vDB3(k, 1) Then
n = n + 1
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, n) = vDB3(k, 1)
vR(2, n) = vDB3(k, 2)
End If
Next
End If
Next j
Next i
If n > 0 Then
Range("e2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End If
End Sub
Here is a code that should do the job. But if Tab1/Tab2 values are not unique then it might do a lookup multiple times. For example if there was 1 in place of 9 in Tab 2 it would show the row with 1 twice in tab 4. If you want to avoid that you will need to modify my code
Set tab1_list = Sheets("sheet1").Range("B6:B10")
Set tab2_list = Sheets("sheet1").Range("C6:C10")
Set tab3_list_lookup = Sheets("sheet1").Range("E6:E10")
Set Tab3_List_value = Sheets("sheet1").Range("F6:F10")
Set output_location = Sheets("sheet1").Range("H6")
For Each cell1 In tab1_list
For Each cell2 In tab2_list
If cell1.Value = cell2.Value Then
For index_no = 1 To tab3_list_lookup.Cells.Count
If tab3_list_lookup.Cells(index_no).Value = cell2.Value Then
output_location.Value = tab3_list_lookup.Cells(index_no).Value
output_location.Offset(0, 1) = Tab3_List_value.Cells(index_no).Value
Set output_location = output_location.Offset(1, 0)
End If
Next index_no
End If
Next cell2
Next cell1
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2). I'd like to set this up such that the program loops through every row in the column (A2:A400), and clears the corresponding values.
I tried using the following code, which I modified from another post:
Sub clear_cell()
Dim v
v = Excel.ThisWorkbook.Sheets("TOP LINE").Range("B2").Value
Dim Arr() As Variant
Arr = Sheet1.Range("C2:DGJ2")
Dim r, c As Long
For r = 1 To UBound(Arr, 1)
For c = 1 To UBound(Arr, 2)
If Arr(r, c) > v Then
Arr(r, c) = ""
End If
Next c
Next r
Sheet1.Range("C2:DGJ2") = Arr
End Sub
I modified it to fit my needs, but it only works for the first row. I need some help getting it to loop through every row in the first column.
Thank you for the help.
I'm trying to write a macro in excel that will identify the first value in a row (A2) and then search the rest of the row to clear any cell with a greater value (C2:DGA2).
From the above statement, I am assuming that all ranges are in the same sheet. Your code works for me if I make a few changes. See this
Sub clear_cell()
Dim i As Long, j As Long
Dim Arr
'~~> Set Range here
Arr = Sheet1.Range("A2:DGJ400").Value
For i = 1 To UBound(Arr, 1)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) > Arr(i, 1) Then
Arr(i, j) = ""
End If
Next j
Next i
'~~> Write back to the sheet
Sheet1.Range("A2:DGJ400") = Arr
End Sub
give this a try:
Sub clear_cell()
x = 2
Do While x <= 400
Y = Range(Cells(x, 2), Cells(x, 2)).Value
If Y < 100 Then Range(Cells(x, 2), Cells(x, 2)).FormulaR1C1 = ""
x = x + 1
Loop
End Sub
The 2 is the column range, in this case B. Good Luck.