I am creating a macro to help organize a data dump (sheet 1) into an invoice (sheet 2). I have coded most of the macro, but am stuck on the following.
I want the macro to read column Y on sheet 1, which is a variable range (can be 2 rows to 50) and check if it says "CB". If this is true, then E11 on sheet 2 is Yes, otherwise No, and so on until it reaches the end of column Y on sheet 1.
I have the following:
Sheets("Data_Dump").Select
intCounter = 1
While Range("Y" & (intCounter + 1)) <> ""
intCounter = intCounter + 1
Wend
intCardSize = intCounter
MsgBox (intCardSize)
Sheets("Data_Dump").Select
If Range("Y" & intCardSize) = "CB" Then
Sheets("Reconciliation").Select
Range("E11:E" & intCardSize).Select
Range("E11") = "Yes"
End If
The while range seems to work and it displays the number of cells with text in column Y, but I can't seem to wrap my head around how to get it to move from Y1 to Y2 and so on and then paste the response into E11 then E12 and so on.
The problem that you are having is that your code doesn't loop to try to compare. The While loop that you have only looks to see if there is something in the next cell. In fact, it actually skips the first row, but maybe that was intentional.
Dim dataSheet As WorkSheet
Dim recSheet As Worksheet
Dim lngCounter As Long 'Use long because an integer may not be big enough for large dataset.
Dim intCardSize As Long
Set dataSheet = ThisWorkbook.Sheets("Data_Dump")
Set recSheet = ThisWorkbook.Sheets("Reconciliation")
'You want to set the sheets to a variable instead of referring to the whole path each time
'Also, Note the usage of "ThisWorkbook" which guarantees the worksheet
'is coming from the one with code in it.
lngCounter = 2 'If you want to start looking at row 2, start at row 2 with
'the variable instead of starting the variable and checking var+1
While dataSheet.Range("Y" & (lngCounter)) <> ""
'While there is a value in the column
'intCardSize = intCounter 'Not sure what this is supposed to do
'MsgBox (intCardSize) 'This looks like debugging. Commenting out.
If dataSheet.Range("Y" & lngCounter) = "CB" Then
'Check each row as you go through the loop.
'Sheets("Reconciliation").Select
'Avoid selecting sheet/range. Unneccessary work for computer.
recSheet.Range("E" & (9 + lngCounter)) = "Yes"
'Set reconciliation sheet value to "Yes" if data sheet has "CB"
'The reconciliation sheet starts on row 11, whereas the datasheet
'starts at row 2 ,a difference of 9
Else
recSheet.Range("E" & (9 + lngCounter)) = "No"
'Otherwise set to no.
End If
lngCounter = lngCounter + 1
Wend
intCardSize = lngCounter - 1 'It's been increased to one past the last item.
MsgBox intCardSize 'Display the last row checked.
I hope I understood your code goal as follows
With Sheets("Data_Dump")
With Sheets("Reconciliation").Range("E11").Resize(.Cells(.Rows.Count,1).Row)
.Formula="=IF('Data_Dump'!Y1="CB", "Yes","")"
.Value= .Value
End With
End With
Related
I'm trying to implement a macro that looks for the words "TRUE" and "FALSE" in a huge array of data - and then, when found, changes the color of the cells above it.
Specifically, I would like it to color not the TRUE/FALSE-cell, but the 30 cells directly above it. This is where things get tricky... I hope someone can help.
I've tried adapting the below code, but mostly I'm adding it as inspiration at this point.
Sub ChangeColor()
lRow = Range("C" & Rows.Count).End(xlUp).Row
Set MR = Range("C2:C" & lRow)
For Each cell In MR
Select Case cell.Value
Case "Yes"
cell_colour = 4
Case "y"
cell_colour = 4
Case Else
cell_colour = 3
End Select
cell.Interior.ColorIndex = cell_colour
Next
End Sub
Using a datafield array
Looping through a range is always time consuming; this should speed it up.
Caveat: Formatting single cells can maximize file size, so at least I reformat the whole column C to xlColorIndexNone.
Option Explicit
Public Sub Mark30CellsAbove()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet")
Dim v As Variant
Dim i As Long, j As Long, n As Long, m As Long, r As Long
Dim Rng As Range
Dim t As Double
' stop watch
t = Timer
' get last row in column C
n = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
' get values to one based 2dim array
v = ws.Range("C1:C" & n).Value
' clear existing colors over the WHOLE column to minimize file size
ws.Range("C:C").Interior.ColorIndex = xlColorIndexNone
' loop through C2:Cn and mark 30 rows before found condition
For i = 2 To n
' check condition, find string "true" or "false"
If InStr(".true.false.", "." & LCase(v(i, 1)) & ".") > 0 Then
' set range block - fixed rows count 30 above found cell
If i < 32 Then ' only in case of less than 30 rows
Set rng = ws.Range("C2:C" & (i - 1))
Else
Set rng = ws.Range("C" & (i - 30) & ":C" & (i - 1))
End If
rng.Interior.ColorIndex = 4
End If
Next i
MsgBox "Time needed: " & Format(Timer - t, "0.00") & " seconds."
End Sub
Of course you could also loop within If - EndIf, just to see this slower method:
If InStr(".true.false.", "." & LCase(v(i, 1)) & ".") > 0 Then
' Always avoid to loop through a range
' For j = i - 1 To i - 30 Step -1
' If j < 2 Then Exit For ' optional escape if one line under title row
' ws.Cells(j, 3).Interior.ColorIndex = 4
' Next
End If
The code that I posted should only highlight cells in column B whose value is different from the corresponding cell in column A. I tested it and it worked OK.
If you want to try conditional formatting:
Select column B, or the part of column B that you want to colour conditionally.
In the following, I will assume that B1 is the active cell within the selection.
On the Home tab of the ribbon, click Conditional Formatting > New Rule...
Select "Use a formula to determine which cells to format".
Enter the formula =B1<>A1
If the active cell is not in row 1, adjust the formula accordingly. For example, if the active cell within the selection is B3, use =B3<>A3
Click Format...
Activate the Fill tab.
Select the desired fill colour.
Click OK until all dialogs have closed.
Change some values in column A and/or B to see the result.
Refer - https://social.technet.microsoft.com/Forums/ie/en-US/2fffa4d8-bbba-473b-9346-5fce8f0728a8/using-vba-to-change-a-cell-colour-based-on-the-information-in-a-different-cell-excel-2010?forum=excel
First you need to check whether the row of the cell is higher than 30 and then it you can offset to change the color:
Thus instead of this line: cell.Interior.ColorIndex = cell_colour
write this:
If cell.Row > 30 Then cell.Offset(-30, 0).Interior.ColorIndex = cell_colour
This may be done without VBA. You should set up two conditional formatting with formulas. First:
=COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW(), COLUMN())),1,0,29,1), "TRUE")>0
and the same for false. To highlight the cell you just need to use Highlight Cell Rules (the top option for CF).
I would do this with conditional formatting
Mark all your data and press "Conditional Formatting". Enter 2 rules with Use a formula...
First rule is for TRUE. Assuming that you start with Col A:
=COUNTIF(A2:A31;TRUE)
The second rule is similar, just exchange TRUE by FALSE. Below the formula, press the "Format" button to set the color.
Explanation:
I reverted the logic: Instead of searching for TRUE/FALSE and then format the cells above, I look for every cell if it has at least one entry TRUE resp. FALSE in the next 30 cells. However, I have to admit I don't know how fast Excel can handle such a large amount of data.
first of all I'm a not good at vba, I used many tuts, but It's not what I want ;)
What I'm trying to accomplish:
Select range of hyperlinks in spreadsheet and set hyperlinks to call another spreadsheet cells (always) from A2 to AX (depends on how many rows I selected).
(Sorry for not proper naming, last time I used vba was about 10y ago)
Before run a script: all hyperlinks are set to different spreadsheet to call cell A2, like this: CommLinkItem_57!A2
Important: it can't be used =HYPERLINK(cell;name) function, couse another script is using this spreadsheet and It not work with this function
After run a script: hyperlinks are not incremented from A2 to AX, instead all hyperlinks (event those that I not selected) are calling last iterated element witch is AX
Sub LoopSelection()
Dim cel As Range
Dim selectedRange As Range
Dim aa As String
Dim counter As Integer
counter = 2
Set selectedRange = Application.Selection
For Each cel In selectedRange.Cells
Debug.Print cel.Address & " " & cel.Hyperlinks.Count
If cel.Hyperlinks.Count > 0 Then
aa = cel.Hyperlinks.Item(1).SubAddress
If cel.Hyperlinks.Item(1).SubAddress Like "*!*" Then
cel.Hyperlinks.Item(1).SubAddress = Trim(Split(aa, "!")(0)) & "!A" & counter
End If
counter = counter + 1
Debug.Print cel.Hyperlinks.Item(1).SubAddress
End If
Next cel
End Sub
For example i select 10 cells form I10 to I20 and then I run a script..
My output in console is like this:
$I$10 1
CommLinkItem_57!A2
$I$11 1
CommLinkItem_57!A3
$I$12 1
CommLinkItem_57!A4
$I$13 1
CommLinkItem_57!A5
$I$14 1
CommLinkItem_57!A6
$I$15 1
CommLinkItem_57!A7
$I$16 1
CommLinkItem_57!A8
$I$17 1
CommLinkItem_57!A9
$I$18 1
CommLinkItem_57!A10
$I$19 1
CommLinkItem_57!A11
$I$20 1
CommLinkItem_57!A12
(works fine, finds proper cells (I10:I20), finds one hyperlink, finds spreadsheet named CommLinkItem_57 and set (in console output) proper incremented cell value from A2 to A12
So in excel cell I10 and I20 are calling CommLinkItem_57!A12.
And that's a problem..
Can you point where I made mistake, and how to fix that problem
Your code is OK. The problem is that worksheets maintain a HyperLinks collection of distinct URLs. I suspect your initial URLs are all the same, hence you're always updating the same HyperLink and end up with the one with the highest counter value. If possible, make your initial URLs distinct.
From what I see the counter should be out of the condition. Like this:
For Each cel In selectedRange.Cells
counter = counter + 1
Debug.Print cel.Address & " " & cel.Hyperlinks.Count
If cel.Hyperlinks.Count > 0 Then
aa = cel.Hyperlinks.Item(1).SubAddress
If cel.Hyperlinks.Item(1).SubAddress Like "*!*" Then
cel.Hyperlinks.Item(1).SubAddress = Trim(Split(aa, "!")(0)) & "!A" & counter
End If
Debug.Print cel.Hyperlinks.Item(1).SubAddress
End If
'or put the counter here, it depends on your code...
Next cel
Like #Excelosaurus said, all hyperlinks were reference like, and when I changed one, all were changed too. So I make workaround and create hyperlinks from basics:
I'm counting from A2 to AX so counter is set to 2
Name of table where nested cells are always is in the same column in index 2, so table name sets row 2, and column of a selected range and takes value of cell i.e. tableName
Hyperlinks are created only in active sheet, line: With Worksheets(Application.ActiveSheet.Index)
If we don't want address to url or file, make Address property, i.e. empty quote ""
I think rest is self-explanatory in code:
Sub LoopSelection()
Dim selectedRange As Range
Dim counter As Integer
Dim tableName As String
counter = 2
Set selectedRange = Application.Selection
tableName = Cells(2, selectedRange.Column).Value
For Each cel In selectedRange.Cells
With Worksheets(Application.ActiveSheet.Index)
.Hyperlinks.Add Anchor:=.Range(cel.Address), _
Address:="", _
SubAddress:=tableName & "!A" & counter, _
TextToDisplay:=tableName
End With
counter = counter + 1
Next cel
End Sub
This is my code I have 2 problems.
The code all works fine but it needs to check if the cell that it is about to write to in "Allocation" holds the value "X1" or "X" if it does then it needs to go to the next person in the list, the peoples names are held in column A. I have solved this bit myself so it is just the last question I need help with now
Each time the loop starts the program needs to check who the last person to be allocated was and start the next allocation from the next persons name in the list of names. If it would help I could post the whole workbook so you can see what it is all doing but you would have to tell me how to do it as I can't seem to find a way of attaching a file. Thank you for looking and any help that may be offered
Public Sub copyothers()
Dim listofcells As Range
Dim currentname As String
Dim foundrow As Integer
Dim foundcolumn As Integer
Dim counter As Integer
Dim i As Integer
Dim personcount() As Variant
Sheets("Availability").Activate
personcount = Sheets("Availability").Range("B3:AR3").Value 'check the
number of people required in each column and record it for later
For i = 2 To 44
Sheets("Availability").Activate
Sheets("Availability").Range("a2").Select
counter = personcount(1, i - 1) - 1 'take the first number reduce
it by 1 and move one column right right each time program loops
If Not Sheets("Availability").Cells(2, i) = "" Then
Sheets("Availability").Range(Cells(2, i), Cells(2,
i).End(xlDown)).Select
Else
GoTo skip: 'If the column has no data then skip to next column
End If
Set listofcells = Selection
Sheets("allocation").Activate
Range("a2").Select
For Each singlecell In listofcells
If counter > 0 Then
If singlecell = "Available" Then
foundcolumn = singlecell.Column 'record the column number where
"Available" was found
currentname = Sheets("Availability").Range("A" & singlecell.Row)
'record the name of the person in the row where "Available" was
found
Set foundName =
Sheets("Allocation").Range("A:A").Find(What:=currentname,
LookIn:=xlValues) 'find the persons name in "Allocation" sheet
foundrow = foundName.Row
If Sheets("allocation").Cells(foundrow, foundcolumn) = ""
Then
Sheets("allocation").Cells(foundrow, foundcolumn) = "X"
'place X in the same cell as it appeared in "Availability" sheet
counter = counter - 1
End If
End If
End If
Next singlecell
skip:
Next i
End Sub
Image form Availability Sheet
Image form Allocation Sheet
I have a code that reads in the new arrangement of columns from a text file and then rearrange the original columns by copying it in at the correct place, however there is a bug in my code. Instead of copying just 1 column it seems to copy all columns to the right of the column that i want to copy..
so i guess the error is here
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead? If i do so the stuff in row 1 will be deleted, below is the full code:
Sub insertColumns()
Call Settings.init
Dim i As Integer
Dim ws As Worksheet
Dim lrow As Integer
Dim columNames As Object
Dim temp As Variant
'fill dictionary with columnnames from text file
Set columNames = FileHandling.getTypes(Settings.columnFile)
Set ws = ActiveWorkbook.Sheets("List")
'Get max column and row number
lColumn = HelpFunctions.getLastColumn(ws, Settings.rowHeader)
lrow = HelpFunctions.getLastRow(ws, HelpFunctions.getColumn("*part*", ws, Settings.rowHeader))
'Insert all new columns in reverse order from dictionary
temp = columNames.keys
For i = columNames.Count - 1 To 0 Step -1
ws.Columns("A:A").Insert Shift:=xlToRight
ws.Range("A" & Settings.rowHeader).Value = temp(i)
Next i
'last column
lastColumn = lColumn + columNames.Count
'we loop through old cells
CounterCol = columNames.Count + 1
Do While CounterCol <= lastColumn
j = 0
'through each elemnt in dictionary
For Each element In temp
j = j + 1
'compare the old rowheader with any of the rowheader in DICTIONARY
If UCase(ws.Cells(Settings.rowHeader, CounterCol).Value) = element Then
'copy the old range
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
'paste it
ws.Cells(Settings.rowHeader + 1, j).Select
ws.Paste
'format the new row
ws.Cells(Settings.rowHeader + 1, j).EntireColumn.AutoFit
'Delete the old row
ws.Columns(CounterCol).EntireColumn.Delete
'decrease the last column by one since we just deleted the last column
lastColumn = lastColumn - 1
found = True
'Exit For
End If
Next element
'Prompt the user that the old column does not match any of the new column
If Not found Then
MsgBox (UCase(ws.Cells(Settings.rowHeader, CounterCol)) & " was not a valid column name please move manually")
End If
'reset the found
found = False
'go to nect column
CounterCol = CounterCol + 1
Loop
End Sub
Below is a screenshot of the dictionary.
After the first iteration/first copy it should have only copied over the part number column, but as can been seen it has copied over more than just the first column(everything except of drawing number)
Q: I want to copy the range AW3:AW80 to A3:A80, but do i need to copy AW:AW to A:A instead?
A: No. Any range can be copied.
Rather than trying to debug your code, I'll give you a hint about how to debug such a thing. Lines like
ws.Range(ws.Cells(Settings.rowHeader + 1, CounterCol), ws.Cells(lrow, CounterCol)).Copy
are hard to debug because they are trying to do too much. You have 4 instances of the dot operator and suspected that the problem was with the last one (.Copy). The problem is almost certainly that your code isn't grabbing the range that you think it is grabbing. In other words, one or more of your method invocations earlier in the line needs debugging. In such a situation it is useful to introduce some range variables, set them equal to various values and print their addresses to the immediate window to see what is happening. As an added benefit, having set range variables allows you to use the full power of intellisence in the VBA editor. Something like:
Dim SourceRange As Range, Cell1 As Range, Cell2 As Range
'
'
'
Set Cell1 = ws.Cells(Settings.rowHeader + 1, CounterCol)
Set Cell2 = ws.Cells(lrow, CounterCol)
Set SourceRange = ws.Range(Cell1, Cell2)
Debug.Print Cell1.Address & ", " & Cell2.Address & ", " & SourceRange.Address
'
'Once the above is debugged:
'
SourceRange.Copy 'should work as expected
It is possible that you are copying the range that you want to copy but that your larger program still isn't working. In that case you have some sort of logic error and should be trying to copy some other range. Even then, the above exercise still helps because it makes it clear exactly what your original line was doing.
'go to nect column
CounterCol = CounterCol + 1
needed to be deleted. It has to do that the column shifts left when i deleted rows.
Thanks for the help. I hope the code can be used for others who might need to add columns, but still copy over content from old columnsin the right order.
I am working with a workbook that currently has 3 sheets. The first sheet is an overview where the filtered data will appear. Cell D11 has the color that I am looking for. Upon entering the color cells F3:I27 Populate with information like color, shape, number and animal.
C2C-Tracker2
I would use a Pivot Table for this, however, I have another set of data in K3:M27. This data is pulled from another sheet within the workbook with a similar function.
The formula that I am using is:
=IFERROR(INDEX(cases!A:A,SMALL(IF(EXACT($D$3,cases!$C:$C),ROW(cases!$C:$C)-ROW($F$1)+1),ROW(1:1))),"")
Of course it is entered using CTRL + SHIFT + ENTER for it to work properly.
I tried using a VBA Macro that I pulled from the video below:
Excel VBA Loop to Find Records Matching Search Criteria
So many array formulas can really make your workbook very slow.
Here is a code to populate Dataset1 using arrays. It runs in less than a second.
Hope this gets you started. I have commented the code but if you still have a problem understanding, just post back :)
Sub Sample()
Dim DSOne() As String
Dim tmpAr As Variant
Dim wsCas As Worksheet: Set wsCas = ThisWorkbook.Sheets("Cases")
Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long, i As Long, j As Long
'~~> Check if user entered a color
If wsMain.Range("D3").Value = "" Then
MsgBox "Please enter a color first", vbCritical, "Missing Color"
Exit Sub
End If
'~~> Clear data for input in main sheet
wsMain.Range("F3:F" & wsMain.Rows.Count).ClearContents
'~~> Get last row of Sheet Cases
lRow = wsCas.Range("A" & wsCas.Rows.Count).End(xlUp).Row
With wsCas
'~~> Get count of cells which have that color
i = Application.WorksheetFunction.CountIf(.Columns(3), wsMain.Range("D3").Value)
'~~> Check if there is any color
If i > 0 Then
'~~> Define your array to hold those values
ReDim DSOne(1 To i, 1 To 4)
'~~> Store the Sheet Cases data in the array
tmpAr = .Range("A1:D" & lRow).Value
j = 1
'~~> Loop through the array to find the matches
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 3) = wsMain.Range("D3").Value Then
DSOne(j, 1) = tmpAr(i, 1)
DSOne(j, 2) = tmpAr(i, 2)
DSOne(j, 3) = tmpAr(i, 3)
DSOne(j, 4) = tmpAr(i, 4)
j = j + 1
End If
Next i
'~~> write to the main sheet in 1 Go!
wsMain.Range("F3").Resize(UBound(DSOne), 4).Value = DSOne
End If
End With
End Sub
Screenshot:
Using the above approach now populate Dataset2 :)