Use Cell Value Reference in VBA to determine range - vba

I know this is a pretty basic question, but im still working on building my VBA skills. I am in a predicament where I have made a mapping system of various reports I receive that get placed in a compiled workbook. These reports have entirely different formats etc. I have a copy/paste macro that copies columns and places them in their correct position on the compiled workbook.
I've come into situations however where there are a lot of duplicate / empty rows that screw up my Macro. I have used two VBA functions to solve this, one is a "delete row if reference column is blank":
Sub DeleteBlankARows()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, 6).End(xlUp).Row To 1 Step -1
If Cells(r, 6) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With End Sub
This deletes rows where cells in column F are empty
I also use a copy/paste down macro:
Sub CopyUntilBlank()
Dim last_row As Integer
last_row = Range("f1").End(xlDown).Row
Dim rng As Range
Set rng = Range("d2:d" & last_row)
For Each cell In rng.Cells
cell.Activate
If ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
Next cell End Sub
This copies and pastes down blank rows in column D until you hit a non-blank cell then re-does this until the range of values in column F.
These macros work well for me, but because I have multiple sheets like this, I would like to create a cell references that make the ranges dynamic. For instance: in the DeleteBlankRows macro, I would like to have the column reference in Cells(r,6) be determined off of a cell value in sheet1 - so for instance if the value in cell A1 on sheet 1 is 2 it would change the column reference to "2" (column B).
I would like the same to happen for the copy/paste down macro. I'm pretty sure this is just some reference to A1.Value but I don't know how to properly write such thing.
Thank you for your support, I've gone quite a long way with all the support of the community.

An example using your first sub:
Sub DeleteBlankARows(colIndex as Long)
Dim colIndex as long
colIndex = Sheet1.Range("a1").value
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Dim r As Long
For r = Cells(Rows.Count, colIndex).End(xlUp).Row To 1 Step -1
If Cells(r, colIndex) = "" Then Rows(r).Delete
Next r
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
It's not clear from your question which column in the second sub needs to be dynamic (or both of them?)
EDIT try this:
Sub CopyUntilBlank()
Dim last_row As Long, col1 as Long, col2 as Long
Dim rng as Range
col1 = Sheet1.Range("a2").value
col2 = Sheet1.Range("a3").value
last_row = Cells(1, col1).End(xlDown).Row
'This next line is better if there's any chance
' of blanks in this column
'last_row = Cells(Rows.Count, col1).End(xlUp).Row
With ActiveSheet
Set rng = .Range(.Cells(2, col2), .Cells(last_row, col2))
End With
For Each cell In rng.Cells
If cell.Value = "" Then
cell.Value = cell.Offset(-1, 0).Value
End If
Next cell
End Sub

Related

Copy and paste as values

I have the code that in general works but it takes forever to run it - I always need to to break it by pressing 'Esc' becuase otherwise I could wait all day long. When I do press 'Esc' the code in general exceutes what it should. But it is annoying and I would like to have it work smoothly.
My code is supposed to execute simple Index formula in one column until then end of the table (i.e.match some word in the other sheet based on the column in front and return it as the result), then it should copy and paste the content in that column to make the formula disappear and leave only the returned values.
Option Explicit
Sub Match_CopyPaste()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim r As Long
Dim endRow As Long
Dim TargetRow As Long
Const ColumnStart As Integer = 2
Const ColumnEnd As Integer = 2
TargetRow = 4
With ThisWorkbook.Sheets("Sheet1")
'*********Clear what is inside********'
.Range(.Cells(TargetRow, ColumnStart), .Cells(.Rows.Count, ColumnEnd)).ClearContents
.Range("A4", .Cells(Rows.Count, "A").End(xlUp)).Offset(0, 1).FormulaR1C1 = "=IFERROR(INDEX(Array,MATCH(RC[-1],Name,0),2),"""")"
End With
'***Part where the problem is:*******
With ThisWorkbook.Sheets("Sheet1")
'************** Copy and paste it as values*********
endRow = .Cells(.Rows.Count, ColumnEnd).End(xlUp).Row
For r = 4 To endRow
Cells(r, ColumnEnd).Value = Cells(r, ColumnEnd).Value
Next r
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I will add that it is the second part of the code (Copy and paste it as values) where the code breaks. Is it something in the code, like the order or structure that makes it impossible to fill long column down ?
as per BigBen comment:
With ThisWorkbook.Sheets("Sheet1")
'************** Copy and paste it as values*********
With .Range(.Cells(4, ColumnEnd), .Cells(.Rows.Count, ColumnEnd).End(xlUp))
.Value = .Value
End With
End With

Excel VBA - Find matching column headings and delete the column

Apologies if this has been answered before, I'm unable to find anything that matches my specific case.
I have a workbook with 18 sheets, and a variable number of columns per sheet starting at B2. Occasionally the program that generates the sheet will create duplicate columns, due to this, I need a macro triggered by button to search each sheet for matching column headers and then delete one of these columns (the whole column, not just the header).
So far I'm pretty stuck, I've been able to delete all matches from any cell in the sheet, which pretty much wipes the entire sheet out. I just need to match headers and then delete the entire column based on that.
Let me know if you need any more information, and thank you for the help!
What I have so far, the code is doing some other stuff too so this needs to continue working.
Sub RemoveExtras()
Dim MyRange As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
BadCharacters = Array(Chr(10), Chr(13))
wsNumber = Sheets.Count
For Each ws In Worksheets
With ws
For Each MyRange In .UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
For Each i In BadCharacters
MyRange = Replace(MyRange, i, vbNullString)
Next i
End If
For t = 1 To wsNumber
Columns(t).RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next t
Next MyRange
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Dictionaries are perfect for handling unique values:
Sub RemoveExtras()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Integer, i As Integer, ws As Worksheet
Dim dict As Object
For Each ws In Worksheets
Set dict = CreateObject("Scripting.Dictionary")
'Find Last column
c = ws.UsedRange.Columns.Count
'Loop backwards
For i = c To 2 Step -1
'If column does not exist in dictionary, then add it
If Not dict.Exists(ws.Cells(2, i).Value) Then
dict.Add ws.Cells(2, i).Value, 1
Else
'Otherwise delete column
ws.Columns(i).Delete Shift:=xlToLeft
End If
Next i
Set dict = Nothing
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Here you do not compare every pair of column headers in the sheet. Also this compares headers across all the worksheets, not just duplicates inside one individual sheet.
See if this helps you
Sub test()
Dim book As Workbook, sheet As Worksheet, text As String
For Each sheet In Worksheets
Set MR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell In MR
Set BR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell2 In BR
If cell.Value = cell2.Value Then cell.EntireColumn.Delete
Next
Next
Next sheet
End Sub

Vba macro if cell contains value, then input specific text on other cells

I have an excel document which has a lot of info and statistics and i am trying to figure out how to solve the following issue:
If a cell on column E, in the interval E5:E70, contains the "N/A" text (without quotes), i want to automatically input the "N/A" text on several specific cells in the same row
Added an image for reference.
Any help would be much appreciated, Thanks !
Latest edit:
I have attached a copy of the excel, maybe it will be a lot more helpful, for me it just won't work...it's so frustrating...
excel file
Paste the code below into the code sheet of the worksheet on which you want to have the action.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Long
If Not Application.Intersect(Target, Range("E5:E70")) Is Nothing Then
SetApplication False
With Target
If StrComp(Trim(.Value), "N/A", vbTextCompare) = 0 Then
' recognises "n/a" as "N/A" and corrects entry
For C = Columns("E").Column To Columns("AL").Column
Cells(.Row, C).Value = "N/A"
Next C
End If
End With
SetApplication True
End If
End Sub
Private Sub SetApplication(ByVal AppMode As Boolean)
With Application
.EnableEvents = AppMode
.ScreenUpdating = AppMode
End With
End Sub
I assumed (based on the picture) that you want paste N/A's in this way: F - paste, G - don't paste, H - paste - and repeat this three further: paste, don't paste, paste, paste, don't paste, paste, etc.
So this code works accordingly to this rule. You just need to specify very last column instead of Column.Count - 2 - this bit says just that program should fill until the last column in a sheet.
Sub FillNAs()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim i, j As Long
For i = 5 To 70
If UCase(Cells(i, 5).Value) = "N/A" Then
j = 6
Do While j < Columns.Count - 2
Cells(i, j).Value = "N/A"
Cells(i, j + 2).Value = "N/A"
j = j + 3
Loop
End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Try
Sub Demo()
Dim ws As Worksheet
Dim cel As Range
Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your data sheet
For Each cel In ws.Range("E5:E70")
If CVErr(cel.Value) = CVErr(xlErrNA) Then
ws.Range("F" & cel.Row & ":I" & cel.Row) = CVErr(xlErrNA) 'mention desired range instead of (F:I)
End If
Next cel
End Sub

VBA Optimizing macro loop

The scenario is that I have 40 sheets and there can be up to ~5k rows in each sheet so I'm dealing with a lot of data which is causing this macro to run extremely slow. For example the first sheet alone has around 15219162 computations which only has about 380 rows. Is there a way to trim down the amount of computations my macro has to run?
There is 39326 unqiue twitter names so far which means 39326 x 387 rows in the first page.
Sub CountInvestorsByTwitterName()
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
End With
Dim row_total As Long
Dim Unique_Values_Sheet As Worksheet
Set Unique_Values_Sheet = Sheets(Sheets.Count)
Unique_Values_Sheet.Columns("B:XFD").EntireColumn.Delete
Dim Unique_Values_Sheet_row_total As Long
Unique_Values_Sheet_row_total = Unique_Values_Sheet.Cells(Rows.Count, "A").End(xlUp).Row
Dim Unqiue_Twitter_Names As Range
Set Unqiue_Twitter_Names = Unique_Values_Sheet.Range("A2:A" & Unique_Values_Sheet_row_total).Cells
For Each s In Sheets
If s.Name <> "UNIQUE_DATA" Then
row_total = s.Cells(Rows.Count, "B").End(xlUp).Row
For Each r In s.Range("B2:B" & row_total).Cells
Twitter_Name = r.Value
For Each c In Unqiue_Twitter_Names
If c.Value = Twitter_Name Then
With c
.Offset(0, 1).Value = CDbl(.Offset(0, 1).Value) + 1
.End(xlToRight).Offset(0, 1).Value = s.Name
End With
End If
Next
Next
End If
' Loop through first sheet
' Exit For
Next
With Application
.Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub
try this
Option Explicit
Sub CountInvestorsByTwitterName2()
Dim row_total As Long
Dim Unqiue_Twitter_Names As Range
Dim found As Range
Dim sht As Worksheet
Dim r As Range, shtRng As Range
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
End With
With Sheets("UNIQUE_DATA")
.Columns("B:XFD").EntireColumn.Delete
Set Unqiue_Twitter_Names = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
End With
For Each sht In Sheets
With sht
If .Name <> "UNIQUE_DATA" Then
Set shtRng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
For Each r In shtRng
Set found = Unqiue_Twitter_Names.Find(What:=r.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not found Is Nothing Then
With found
.Offset(0, 1).Value = CDbl(.Offset(0, 1).Value) + 1
.End(xlToRight).Offset(0, 1).Value = sht.Name
End With
End If
Next
End If
End With
Next
With Application
.Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub
if not sufficiently fast, you could try some "array" approach, storing relevant sheet cells values in a array and performing searching with them
also a Dictionary approach could be worth examinating
What I would do:
1) Clear the entire 'UNIQUE_DATA' sheet.
2) Loop through all worksheets, and if the name of the sheet isn't 'UNIQUE DATA', copy all rows with content to 'UNIQUE_DATA' (copy-paste rows, after detecting beforehand which rows, and at which lines to insert them)
3) Sort all rows in 'UNIQUE DATA' on the column containing the twitter handles. Macro code is easy to figure out if you macro-record it once.
4) Loop through all rows in sheet 'UNIQUE_DATA', and compare value of Twitter handle with the Twitter handle for the row below. If they match, delete the next row (and lower the upper bound of your loop counter).
You should end up with all unique Twitter handles.
I do have to agree the last step may take some time. But at least doing this is a complexity of O(n) rather then O(n²) you currently have with two nested loops. Especially for high values of n, the time difference should be significant.

Check merged cell and compare adjacent to set unique value from compared cells values

I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub