I am trying to give a color to the entire row that is blank but only if above a specific text. The specific text is on column A. Struggling to find a code that i can use /modify, can you please help?
Sub Reformat()
Dim SrchRng3 As Range
Dim c3 As Range, f As String
Set SrchRng3 = Sheets("RAW DATA FILE").Range("B:B").End(xlUp))
Set c3 = SrchRng3.Find("Customer account", LookIn:=xlValues)
If Not c3 Is Nothing Then
f = c3.Address
Do
With Sheets("RAW DATA FILE").Range("A" & c3.Row & ":Q" & c3.Row)
.Interior.ColorIndex = 53
End With
Set c3 = SrchRng3.FindNext(c3)
Loop While c3.Address <> f
End If
End Sub
You were already pretty close, try this adjusted code:
Sub Reformat()
Dim SrchRng3 As Range, ws As Worksheet
Dim c3 As Range, f As String
Dim colorRange As Range
Set ws = Sheets("RAW DATA FILE")
Set SrchRng3 = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp))
Set c3 = SrchRng3.Find("Customer account", LookIn:=xlValues)
If Not c3 Is Nothing Then
f = c3.Address
Do
Set colorRange = ws.Range("A" & c3.Row - 1 & ":Q" & c3.Row - 1)
If WorksheetFunction.CountA(colorRange) = 0 Then colorRange.Interior.ColorIndex = 53
Set c3 = SrchRng3.FindNext(c3)
Loop While c3.Address <> f
End If
End Sub
In your original code you were looking for your specified string in column B, not column A.
Related
Focusing on:
rows = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
Instead of looking at the whole cell to match (xlwhole), I'm trying to only match the first 6 characters of the cell. I've looked into xlpart and a few other options but have been unsuccessful.
Sub test()
Dim aCell
Dim A, B As Long, rows As Long
Dim w1, w2 As Worksheet
Dim cell As Range
Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet1")
A = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
B = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
For Each aCell In w1.Range("A2:A" & A)
On Error Resume Next
rows = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
On Error GoTo 0
If rows = 0 Then
Else
w2.Range("B" & rows).Value = aCell.Offset(0, 1).Value
End If
rows = 0
Next
End Sub
Find supports wildcards *. Use Left$ to get the first 6 characters of the cell value.
For Each aCell In w1.Range("A2:A" & A)
Dim rng As Range
Set rng = w2.Columns("A:A").Find(What:=Left$(aCell.Value, 6) & "*", LookAt:=xlWhole)
' First test if the find succeeded
If Not rng Is Nothing Then
rng.Offset(,1).Value = aCell.Offset(,1).Value
End If
Next
Hi all I am working on a project and am stuck with transposing the range and storing it in a variable to be used in my index match formula.
The project consists of two worksheets: The inventory worksheet where all of the data is stored, and the ad sheet (where the data will be printed into a table). The variable d is storing the headers of the table on the ad sheet (to be used to match with names in column E of Inventory worksheet). The variable c is the active cell (where the transposed data will be printed).
Essentially I want to get the Range M2:SlastRow on the inventory worksheet, transpose it and then use that as my return range.
The Index match should match the headers from the table (one row above active cell) with the same headers in column E on the Inventory sheet. Then it should print in the active cell column the corresponding data (M:S of the Inventory sheet) and move over to the next column, repeating until the header is empty on the ad sheet.
Below is my code:
Dim ws As Worksheet, lastRow As Long, c As Range, d As Range, ms As Range
Dim f As String
Dim arr As Variant, arr2 As Variant
Set ws = Worksheets("Inventory")
lastRow = Application.Max(ws.Range("E100000").End(xlUp).Row, _
ws.Range("S100000").End(xlUp).Row)
Set c = ActiveCell
Set d = ActiveCell.Offset(-1, 0)
Set ms = Worksheets("Inventory").Range("$M$2:$S$" & lastRow)
arr = Application.Transpose(ms)
arr2 = Application.Transpose(arr)
Do
f = "=IFERROR(INDEX(& arr2 &, MATCH(1, INDEX((& d &=<addrE>),0,1),0)),0)"
f = Replace(f, "<addrE>", "'" & ws.Name & "'!$E$2:$E$" & lastRow)
c.Formula = f
Set c = c.Offset(0, 1)
Set d = d.Offset(0.1)
Loop While Not IsEmpty(d)
Important to note that I am getting an "Application-defined or object-defined error" on the c.Formula = f line
Just transpose the row that matches.
Option Explicit
Sub macro1()
Dim wb As Workbook, ws As Worksheet, wsAd As Worksheet
Dim colE As Range, rowMS As Range, cell As Range
Dim arr As Variant, r As Variant
Dim lastRow As Long
Set wb = ThisWorkbook ' or activeworkbook
Set ws = wb.Worksheets("Inventory")
Set wsAd = wb.Worksheets("Ad")
lastRow = Application.Max(ws.Range("E" & Rows.Count).End(xlUp).Row, _
ws.Range("S" & Rows.Count).End(xlUp).Row)
Set colE = ws.Range("E1:E" & lastRow)
Set rowMS = ws.Range("M1:S1")
Set cell = wsAd.Range("A1")
Do
' match header
r = Application.Match(cell, colE, 0)
If IsError(r) Then
MsgBox "Could not match " & cell.Value, vbExclamation
Else
arr = Application.Transpose(rowMS.Offset(r - 1, 0))
cell.Offset(1, 0).Resize(UBound(arr)).Value2 = arr
End If
Set cell = cell.Offset(0, 1)
Loop While Not IsEmpty(cell)
MsgBox "Done"
End Sub
I need to select the demand range in sheet 1 corresponding to the part number selected in Sheet 2 of my workbook. So far, I have written the macro to automatically select the part number in sheet 1 when the same part number is selected in sheet no 2. But, I'm having trouble selecting the range corresponding to the part number, which I want to base my calculations on. Can anyone please tell me how to select the range?
Public Sub calculation()
Dim x As Variant
Dim rng As Range
Dim i As Variant
Dim j As Integer
Dim findcell As Range
Dim a_1 As Range
Dim b_1 As Range
Dim rnge As Range
Worksheets("Sheet2").Activate
x = Worksheets("Sheet2").Range("C3").Value
Worksheets("Sheet1").Activate
Set rng = Worksheets("Sheet1").Range("A2:A26")
For Each i In rng
If x = i Then
Set findcell = i
End If
Next i
j = findcell.Select
Set a_1 = ActiveCell.Offset(0, 1)
Set b_1 = ActiveCell.Offset(0, 66)
Worksheets("Sheet2").Range("C9").Value "=AVERAGE(Sheet1!"a_1.Address":"b_1.Address")"
End Sub
Should be able to do something like this:
Public Sub calculation()
Dim f As Range
Set f = Worksheets("Sheet1").Range("A2:A26").Find( _
what:=Worksheets("Sheet2").Range("C3").Value, _
lookat:=xlWhole)
With Worksheets("Sheet2").Range("C9")
If Not f Is Nothing Then
.Formula = "=AVERAGE(Sheet1!" & f.Offset(0, 1).Resize(1, 66).Address & ")"
Else
.Value = "???"
End If
End With
End Sub
I would like to filter my Excel table with VBA code.
A1, B1, C1 are titles
Column A = All (A2: xx)
Column B = Search Content`s (B2: xx)
Column C = (C2: xx)
Everything in column B should be searched for column A and if one or more is found then column C should be written.
I tried the following.
Sheets("Tabelle2").Range("A2:A2000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("B2:B2000"), CopyToRange:=Range("C2:C2000")
So that everything in column A is copied to column C but not to be compared to column B.
How can I make this work?
I suggest you to use a helping column, then you can easily do that without VBA coding.
Helping column formula:
=IF(ISERROR(MATCH(A2,$B$2:$B$9,0)),ROW(),"")
Then use following formula to extract not backuped servers list.
=IFERROR(INDEX($A$2:$A$31,SMALL($D$2:$D$31,ROW(1:1))),"")
See the file
You have to include Title.
Sub test()
Dim rngDB As Range
Dim rngCria As Range
Dim rngTo As Range
Dim Ws As Worksheet
Set Ws = Sheets("Tabelle2")
With Ws
Set rngDB = .Range("a1:a2000")
Set rngCria = .Range("B1", .Range("b" & Rows.Count).End(xlUp))
Set rngTo = .Range("c1")
End With
rngDB.AdvancedFilter xlFilterCopy, rngCria, rngTo
End Sub
Option Explicit
Sub ListMatches()
Dim rngColumnA As Range, celColumnB As Range, rngColumnB As Range
Set rngColumnA = Range("A2:A" & Range("A1000000").End(xlUp).Row)
Set rngColumnB = Range("B2:B" & Range("B1000000").End(xlUp).Row)
For Each celColumnB In rngColumnB
If Not rngColumnA.Find(What:=celColumnB) Is Nothing Then Range("C" & Range("C1000000").End(xlUp).Row + 1) = celColumnB.Value
Next celColumnB
End Sub
Using A Collection might be even faster in your application:
Sub ListMatches()
Dim R1 As Range, R2 As Range, R As Range, Nc As New Collection
Set R1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
Set R2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
On Error Resume Next
For Each R In R1
Nc.Add R.Value, R.Value
Next R
For Each R In R2
Err = 0
Nc.Add R.Value, R.Value, 1
If Err = 0 Then
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = R.Value
Nc.Remove 1
End If
Next R
On Error GoTo 0
End Sub
I have two worksheets ( sheet 1 and sheet 2) . Sheet 1 has 500X500 table. I want to
- Loop through each row ( each cell )
- Identify the cells which have a value ' X' in it
- Pick the respective column header value and store it in a cell in worksheet 2
For example
AA BB CC DD EE FF GG HH
GHS X
FSJ X
FSA X
MSD
SKD
SFJ X X
SFJ
SFM X
MSF X
Is there a way of writing a macro which will pull values in the form of
GHS -> GG
FSJ->DD
.
.
SFJ->BB HH
I have tried looping algorithms but does not seem to work. Could anyone please help me as I am very new to macros.
Try this .. Assumed that GHS, FSJ ... in column A
Sub ColnItem()
Dim x, y, z As Integer
Dim sItem, sCol As String
Dim r As Range
z = 1
For y = 1 To 500
sItem = Cells(y, 1)
sCol = ""
For x = 2 To 500
If UCase(Cells(y, x)) = "X" Then
If Len(sCol) > 0 Then sCol = sCol & " "
sCol = sCol & ColumnName(x)
End If
Next
If Len(sCol) > 0 Then
Sheets("Sheet2").Cells(z, 1) = sItem & " -> " & sCol
z = z + 1
End If
Next
End Sub
Function ColumnName(ByVal nCol As Single) As String
Dim sC As String
Dim nC, nRest, nDivRes As Integer
sC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nC = Len(sC)
nRest = nCol Mod nC
nDivRes = (nCol - nRest) / nC
If nDivRes > 0 Then ColumnName = Mid(sC, nDivRes, 1)
ColumnName = ColumnName & Mid(sC, nRest, 1)
End Function
I have placed the values GG, etc., in separate columns of Sheet2, but the code could be modified to put all the information (for a row) in a single cell.
Sub GetColumnHeadings()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range, rng As Range
Dim off As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng1 = ws1.Range("A1").CurrentRegion
'CurrentRegion is the Range highlighted when we press Ctrl-A from A1
Set rng2 = ws2.Range("A1")
Application.ScreenUpdating = False
For Each rng In rng1
If rng.Column = 1 Then off = 0
If rng.Value = "X" Then
rng2.Value = rng.EntireRow.Cells(1, 1).Value
off = off + 1
rng2.Offset(0, off).Value = rng.EntireColumn.Cells(1, 1).Value
End If
'if we are looking at the last column of the Sheet1 data, and
'we have put something into the current row of Sheet2, move to
'the next row down (in Sheet2)
If rng.Column = rng1.Column And rng2.Value <> "" Then
Set rng2 = rng2.Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
Set rng = Nothing
Set rng2 = Nothing
Set rng1 = Nothing
Set ws2 = Nothing
Set ws1 = Nothing
End Sub
I've also based in on the spreadsheet sample from the original post, where AA appears to be in cell A1.