I'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub
Related
I am working on my vba exercise and I have two columns L and I. The value in column I depends on column L.
So if column L has value "s" in a row then column I should have value "0" in the same row, otherwise the I, L column should be colored red.
If column L has one of the values in array in a row then column I should have nothing in the same
row, otherwise the I, L column should be colored red.
The problem is I struggle to make it work in VBA
Also, even if there is a way to do it differently then in VBA I have to do this exercise in VBA.
How can I compare values from the same row that are in two different columns that are not next to each other? Can you help?
Sub validate()
Dim i As Long
Set active_sheet = ActiveSheet
LstRow = active_sheet.Range("I" & active_sheet.Rows.Count).End(xlUp).Row
Set RngOrders = active_sheet.Range("L2:L" & last_row)
Set RngPackages = active_sheet.Range("I2:L" & LstRow)
MValues = Array("M", "kg", "j.m.", "g")
For i = 1 To RngPackages
If RngOrders(i) = "s" And RngPackages(i) <> "0" Then
RngPackages(i).Interior.Color = vbRed
ElseIf RngOrders(i) in MValues And RngPackages(i) <> "" Then
RngPackages(i).Interior.Color = vbRed
Next i
End Sub
Sub validate_someones_homework()
' Tools -> References -> Microsoft Scripting Runtime -> check
Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim MValues As New Scripting.Dictionary
MValues.Add "M", 0
MValues.Add "kg", 0
MValues.Add "j.m.", 0
MValues.Add "g", 0
Dim r As Long
For r = 1 To lastRow
If ws.Cells(r, 12).Value = "s" And Not ws.Cells(r, 9).Value = 0 Then
ws.Cells(r, 9).Interior.Color = vbRed
ElseIf MValues.Exists(ws.Cells(r, 12).Value) And Not ws.Cells(r, 9).Value = "" Then
ws.Cells(r, 9).Interior.Color = vbRed
End If
Next r
End Sub
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i
I have two columns (B & C) containing names, but I'm looking to make sure certain words are flagged for review by changing the cell fill color.
It seems I'm not much familiar with VBA anymore, but I'm having to dabble some to get a much needed macro to work. Like I said above, I have two columns (B & C) containing names, but I'm looking to make sure certain words are flagged for review by changing the cell fill color. The words I'm looking for are "hope" and "trust", and they're likely a part of some values.
Sub FindTrustHope()
Dim B As Long, C As Long, i As Long
Dim findTrust As String
Dim findHope As String
B = Cells(Rows.Count, "B").End(xlUp).Row
C = Cells(Rows.Count, "C").End(xlUp).Row
findTrust = "trust"
findHope = "hope"
For i = B To 1 Step -1
If Cells(i, "B") = findTrust Or Cells(i, "B") = findHope Then
Cells(i, "B").Interior.Color = vbRed
End If
If Cells(i, "C") = findTrust Or Cells(i, "C") = findHope Then
Cells(i, "C").Interior.Color = vbRed
End If
Next i
End Sub
The code below should do the trick for you.
Sub FindTrustHope()
Dim B As Long, C As Long, i As Long
Dim findTrust As String
Dim findHope As String
B = Cells(Rows.Count, "B").End(xlUp).Row
C = Cells(Rows.Count, "C").End(xlUp).Row
findTrust = "trust"
findHope = "hope"
For i = B To 1 Step -1
If InStr(Cells(i, "B"), findTrust) > 0 Or InStr(Cells(i, "B"), findHope) > 0 Then
Cells(i, "B").Interior.Color = vbRed
End If
If InStr(Cells(i, "C"), findTrust) > 0 Or InStr(Cells(i, "C"), findHope) > 0 Then
Cells(i, "C").Interior.Color = vbRed
End If
Next i
End Sub
I have a listbox with six columns that I am adding to when the user selects a visit# that corresponds to the Range("A2") in my worksheet. The data adds in but it will also add blank rows every time something is added to a column. Here is what I have. I don't have any blank rows with the corresponding number so I am not sure why it is adding blanks. Check out image for my excel data.
Private Sub cboVisitNo_Click()
Dim j As Integer, k As Integer, i As Integer
Worksheets("Biopsy Log").Select
Me.lstBNum.Clear
i = 0
For j = 1 To Range("A2", Range("A1").End(xlDown)).Rows.count
If Range("A2", Range("A2").End(xlDown)).Cells(j) = Me.cboVisitNo.Value Then
With Me.lstBNum
For k = 0 To 5
.AddItem
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
Next
End Sub
Untested:
Private Sub cboVisitNo_Click()
Dim j As Long, k As Long, i As Long
Dim c As Range
Me.lstBNum.Clear
i = 0
With Worksheets("Biopsy Log")
For Each c In .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Cells
If c.Value = Me.cboVisitNo.Value Then
Me.lstBNum.AddItem '<< edit ###
For k = 0 To 5
Me.lstBNum.List(i, k) = c.Offset(0, k)
Next
i = i + 1
End If
Next c
End With
End Sub
I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub