I am not great at this yet, but I am trying to do this without copy-pasting code... not sure its the best idea.
I am trying to search for to different values in two columns and then return a different if both columns match. In the end I will be pulling from about 9 different workbooks.
Dim wbACF As Workbook
Dim wsDiv As Worksheet
Dim rng As Range
Dim WC As String
Dim vCELL As Variant
Dim switch As Variant
Dim nvCell As Variant
Dim lastCell As Variant
Set wbACF = Workbooks("ACF.xls")
WC = Sheet1.Cells(5, 14).Value
nvCell = "A1"
lastCell = "A999"
Set wsDiv = wbACF.Worksheets(WC)
Set rng = wsDiv.Range(nvCell, lastCell)
switch = 1
Do While switch = 1
vCELL = Application.Match("test", rng, 0)
If wsDiv.Cells(vCELL, 7).Value = Sheet1.Cells(5, 13).Value Then
Sheet1.Cells(11, 1).Value = wsDiv.Cells(vCELL, 4)
switch = 0
Else
nvCell = "A" & vCELL + 1
Set rng = wsDiv.Range(nvCell, lastCell)
End If
Loop
for my test files, rows 10, 70, 150 and 210 match for test, but only row 210 match for both test and Sheet1.Cells(5, 13).Value
vCELL becomes 10 in the first loop, and then executes the else portion, on the second loop vCELL becomes 60 and then never changes. I am sure my coding is poor, and is a contributing factor, but any help would be appriciated.
Related
I have this small piece of code.
Sub FillRemainingDates()
Dim SearchRange As Range
Set SearchRange = Sheets(1).UsedRange.Columns(11)
Dim cell As Range
For Each cell In SearchRange
If cell.Value = vbNullString And cell.Offset(0, 9).Value = cell.Offset(1, 9).Value Then
cell = cell.Offset(1, 0).Value
End If
Next
End Sub
Its goal is to attribute a value to a cell in a column depending on the value of a cell a row below:
The macro "works" in the sense that it does what I expect it to do, but whenever I run it it causes the program to become unresponsive and freeze for a long time.
I think I'm missing something in the loop and it's causing the program to fall into an infinite loop or have to deal with more data than necessary.
You should use an array to work on - and then write that back to the sheet.
Sub FillRemainingDates()
'ASSUMPTION: data start in column A
'>>> change the names according to your project
Const colNameOfColumn11 As Long = 11
Const colNameOfColumn20 As Long = 20
Dim arrSearch As Variant
arrSearch = Worksheets(1).UsedRange
Dim i As Long
Dim varValue As Variant '>>>> change type according to your values
For i = 1 To UBound(arrSearch, 1) - 1 ' don't check last row
varValue = arrSearch(i, colNameOfColumn11)
If varValue = vbNullString And _
arrSearch(i, colNameOfColumn20) = arrSearch(i + 1, colNameOfColumn20) Then
arrSearch(i, colNameOfColumn11) = arrSearch(i + 1, colNameOfColumn11)
End If
Next
Worksheets(1).UsedRange.Value = arrSearch
End Sub
My ultimate goal is to read a range from one workbook and input it into specific cells in another workbook. The source Workbook has a range of autofiltered data in columns A-D. The destination workbook has 8 fields that need to be filled and they will always be the same. For instance, The source workbook will have the first field of the Array MyArray(x) go into the field B2 on the destination workbook. Then MyArray(x) will have x=2 which will populate D2 in the destination workbook from the next visible row in column B. So, it would look like this:
Source workbook
A
B
C
D
1
User Name
AccountNo
Last3
Software to Load
3
User 2
10161_4002
MM1
License E3
4
User 3
10202_2179
118
6
User 5
10141_9863
AA5
License-E3,Reflection
7
User 6
10167_3006
B35
RSI,Java
9
User 8
10176_3393
W45
Office365,Java
And the destination workbook would look like this:
A
B
C
D
1
2
Name:
Account Number:
3
ID:
Software:
4
5
Name:
Account Number:
6
ID:
Software:
So, after running to sub/function, I would have:
[D]=Destination [S]=Source
[D]B2=[S]A3
[D]D2=[S]B3
[D]B3=[S]C3
[D]D3=[S]D3
[D]B5=[S]A4
[D]D5=[S]B4
[D]B6=[S]C4
[D]D6=[S]D4
And so on with 2 rows from the source getting put into the 8 fields of the destination workbook. I have some very basic code at this point but I know this is pretty convoluted. Here is what I've come up with so far which just loops through all of the visible rows and prints out the lines from the range from A2 through the last cell in D with data in it to the immediate window. I've removed it from my main project and just put it all in 2 new workbooks to simplify everything. Ultimately, I'm going to print each page when the destination gets all 8 fields updated and move on to the next page. My code so far:
Sub AddToPrintoutAndPrint()
Dim rng As Range, lastRow As Long
Dim myArray() As Variant, myString() As String
Dim cell As Range, x As Long, y As Long
Dim ws As Worksheet: Set ws = Sheet1 ' Sheet1
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = Range("A2:D" & lastRow)
For Each cell In rng.SpecialCells(xlCellTypeVisible)
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
For x = LBound(myArray) To UBound(myArray)
Debug.Print Trim$(myArray(x))
Next x
Set ws = Nothing
End Sub
Thanks for any suggestions
Edit: New block of code to support printing multiple lines
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Dim rowCounter As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng.SpecialCells(xlCellTypeVisible))
'This is used to keep a running total of how many rows
'were populated. Since the entries are three rows apart
'we can use the offset function in the loop to choose
'the correct entry. This is also flexible enough
'such that if you ever wanted three or more entries
'per sheet, it will work.
rowCounter = 0
For Each itm In coll
wsDest.Range("B2").Offset(rowCounter * 3).Value = itm(0)
wsDest.Range("D2").Offset(rowCounter * 3).Value = itm(1)
wsDest.Range("B3").Offset(rowCounter * 3).Value = itm(2)
wsDest.Range("D3").Offset(rowCounter * 3).Value = itm(3)
'Increment rowcouter, looping around if you surpass
'two (or any future max number of items)
rowCounter = (rowCounter + 1) Mod 2
'If rowCounter has reset to 0, that means its time to
'print or whatever yuo need to do. Do it below
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
Next itm
'Here we check if rowcounter does not equal 0. This indicates
'that the loop ended with an odd number of elements, and should be
'printed out to flush that "buffer"
If rowCounter <> 0 Then
'Do final printout
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
End If
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'd manage it a bit differently. First, I don't think it's wise to ReDim an array in a loop. I'm not sure how efficiently VBA manages resizing arrays, but it can be an expensive process.
I'd store the relevant values from each row into a collection. The items in the collection will be an array with the relevant fields. This collection can then be looped over, with the data being dropped into the relevant fields (and then printed, or whatever needs to be done).
Let me know if this gets you started.
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng)
For Each itm In coll
wsDest.Range("B2").Value = itm(0)
wsDest.Range("D2").Value = itm(1)
wsDest.Range("B3").Value = itm(2)
wsDest.Range("D3").Value = itm(3)
'Maybe do your print routine here, and then reload
Next itm
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'm new to vba and stackoverflow so please go easy on me!
I have two worksheets, call worksheet1 = GoldCopy and worksheet2 = A-OPS. They have about 10,000+ rows of data and should have some similar data. I want to compare the two sheets. Both of them have similar headers: Column A = filename and Column D = encryption code Column B = file path and Column F = in gold (or A-OPS depending on what ws you're looking at).
I want to be able to compare ws1 and ws2 and check for any discrepancies and highlight them as FALSE and the color red in column F. I currently want to check ws1 and go through each row, see if that filename and encryption code is in ws2, doesn't have to be the same row as ws1, but I want the filename and encryption code to be the same row (does that make sense?) WS2 could have this data in row 20 but ws1 would be on row 10 but since they have the same filename and encryption, then that's fine. If ws2 has the same filename AND same encryption code, then ws1 column F is TRUE. If ws2 does not have the same filename AND encryption in any of the rows, then ws1 column F is FALSE. I also want to do this same thing, except check ws2 against ws1.
This is the code I have so far, but it is taking forever because of these nested for loops. I have tried looking into something called "arrays" but I'm just very confused and would like something fast and efficient. The for loop is taking a really long time. Please let me know if I need to be more specific or explain more! Thanks so much
Sub Check
For Each s In Sheets
'NEW FILE SEARCH A-NAS OPS'
If s.Name = "A OPS" Then 'check if there is an A OPS file if so then proceed'
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("A OPS").Cells(1, ACOL + 1).Value = "In Gold Copy?"
'GoldCopy Check with A-NAS OPS'
Worksheets("GoldCopy").Activate
GROW = Worksheets("GoldCopy").Cells(Rows.Count, 1).End(xlUp).Row
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
AROW = Worksheets("A OPS").Cells(Rows.Count, 1).End(xlUp).Row
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("GoldCopy").Cells(1, GCOL + 1) = "Deployed in A OPS?"
For i = 2 To GROW
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("GoldCopy").Cells(i, 3), "\sidata\") > 0 Then 'this is checking to see for a filepath from column B'
bln = False
For x = 2 To AROW
If Worksheets("GoldCopy").Cells(i, 1).Value = Worksheets("A OPS").Cells(x, 1) And Worksheets("GoldCopy").Cells(i, 4).Value = Worksheets("A OPS").Cells(x, 4).Value Then 'if the filename and encryption code in the same row in ws2 match ws1 then do next step'
bln = True
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("GoldCopy").Cells(i, GCOL) = bln
Worksheets("GoldCopy").Cells(i, GCOL).Interior.ColorIndex = 22
End If
Next x
End If
Next i
'A OPS check with GoldCopy'
Worksheets("A OPS").Activate
GROW = Worksheets("GoldCopy").Cells(Rows.Count, 1).End(xlUp).Row
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
AROW = Worksheets("A OPS").Cells(Rows.Count, 1).End(xlUp).Row
ACOL = Worksheets("A OPS").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To AROW
GCOL = Worksheets("GoldCopy").Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\common\") > 0 Or InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\j01\ecl\") > 0 Or InStr(Worksheets("A OPS").Cells(i, 3), "\SIDATA\ops\npp\ecl\") > 0 Then
bln = False
For x = 2 To GROW
If Worksheets("GoldCopy").Cells(x, 1).Value = Worksheets("A OPS").Cells(i, 1) And Worksheets("GoldCopy").Cells(x, 4).Value = Worksheets("A OPS").Cells(i, 4).Value Then
bln = True
Worksheets("A OPS").Cells(i, ACOL) = bln
Worksheets("A OPS").Cells(i, ACOL).Interior.ColorIndex = 10
Exit For
Else
Worksheets("A OPS").Cells(i, ACOL) = bln
Worksheets("A OPS").Cells(i, ACOL).Interior.ColorIndex = 22
End If
Next
End If
Next
Try to work through the below code. I dispersed comments throughout the code to indicate what the code does and why it does it. See if you can adapt it to your actual workbook. If you run into issues, write back and we'll try to work through them.
'Below code drives the analysis. Get a dictionary of
'unique keys from each sheet, then compare each sheet
'separately. You can pull your "response" into a separate
'function if you need the flexibility to change
Sub AnalyzeSheets()
Dim oGold As Object
Dim oAops As Object
Dim shtGold As Worksheet
Dim shtOps As Worksheet
Dim rngGold As Range
Dim rngOps As Range
Dim iterator As Range
Dim theKey As String
Set shtGold = Worksheets("GoldCopy")
Set shtOps = Worksheets("A Ops")
'Establish the data range for each sheet
'Mine is simply hardcoded
Set rngGold = shtGold.Range("A2:E8")
Set rngOps = shtOps.Range("A2:E7")
'Get a dictionary for each sheet. Pass in
'the range of the data
Set oGold = GetDictionary(rngGold)
Set oAops = GetDictionary(rngOps)
'Analyze each sheet separately
'Use Intersect to only iterate over the cells in the first column
For Each iterator In Intersect(rngGold, shtGold.Columns(1))
theKey = CreateKey(iterator.Value, iterator.Offset(, 3).Value)
If Not oAops.exists(theKey) Then
Respond iterator, False
Else
Respond iterator, True
End If
Next iterator
For Each iterator In Intersect(rngOps, shtOps.Columns(1))
theKey = CreateKey(iterator.Value, iterator.Offset(, 3).Value)
If Not oGold.exists(theKey) Then
'Call a response function. By putting the response
'into it's own function, you don't have to duplicate logic
'and it's easier to change
Respond iterator, False
Else
Respond iterator, True
End If
Next iterator
End Sub
Sub Respond(rng As Range, isFound As Boolean)
Dim sht As Worksheet
Set sht = rng.Parent
If isFound Then
sht.Range("F" & rng.Row).Value = "TRUE"
sht.Range("F" & rng.Row).Interior.ColorIndex = 10
Else
sht.Range("F" & rng.Row).Value = "FALSE"
sht.Range("F" & rng.Row).Interior.ColorIndex = 22
End If
End Sub
'Use this function to generate a unique key for each row
'Since 2 columns form a unique key, I'm simply taking each
'value and joining with a hypen. By pulling this logic into
'it's own function, you have more flexibility for future changes.
Function CreateKey(s1 As String, s2 As String) As String
Dim delimiter As String
delimiter = "-"
CreateKey = s1 & delimiter & s2
End Function
'Use below to create a dictionary holding unique key values
'You can update the code within to identify which cells
'are used to generate a key
Function GetDictionary(inputRange As Range) As Object
Dim oDict As Object
Dim sht As Worksheet
Dim cel As Range
Dim theKey As String
Set sht = inputRange.Parent
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In Intersect(inputRange, sht.Columns(1))
'(A) - Filename (D) - Encryption
theKey = CreateKey(sht.Range("A" & cel.Row).Value, _
sht.Range("D" & cel.Row).Value)
'If the key hasn't been added, add it (don't need value)
If Not oDict.exists(theKey) Then
oDict.Add theKey, ""
End If
Next cel
Set GetDictionary = oDict
End Function
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I have merged cells in my sheet "interspersed" and not in any pattern.
I need to replace the blank merged cells with "-"; dash.
Is there a faster way than this:
Sub ReplaceblankMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
If c.Value = "" Then
c.Value = "_"
End If
End If
Next
End Sub
I think you could break up the entire range to check in chunks, and check if each of these chunks contains merged cells. In the case of this being false, you won't have to check each cell in such a chunk, thereby saving time. How much time you would save, if any, would vary on your setup and the amount of chunks you specify.
Option Explicit
Sub ReplaceblankMergedCells()
Dim c As Range, r As Range
Dim startcolumn As Long, endcolumn As Long, startrow As Long, endrow As Long
Dim totalchunks As Integer, chunkcols As Integer, i As Integer
With Sheet2 'Edit
startcolumn = 1
endcolumn = 50
startrow = 2
endrow = 1000
totalchunks = 10 'set amount of chunks
chunkcols = Application.WorksheetFunction.RoundUp((endcolumn - startcolumn + 1) / totalchunks , 0) '10 chunks of 5 columns
For i = startcolumn To endcolumn Step chunkcols
Set r = .Range(.Cells(startrow, i), .Cells(endrow, i + chunkcols - 1))
'Prevent the loop from overshooting the last column
If i + chunkcols - 1 > endcolumn Then Set r = .Range(.Cells(startrow, i), .Cells(endrow, endcolumn))
'check if the chunk contains merged cells
If IsNull(r.MergeCells) = True Or r.MergeCells = True Then
'If it does contain merged cells, loop through the chunk
For Each c In r
If c.MergeCells And c.Value = "" Then c.Value = "_"
Next c
End If
Next i
End With
End Sub
As you can (hopefully) tell, I have divided the set range by ten. This breaks up the range in 10 equal parts of 5 rows, in case of the total amount of columns in the range being 50.
I advise you to play around with how large these chunks should be. You could also break up the chunks in more chunks horizontally, say half the rows in one sub-chunk and the other half in another sub-chunk.
Specify your worksheet or change the determination of the sheet and see if this does it for you ...
Public Sub ReplaceMergeCellsWithHyphen()
Dim objCells As Range, objCell As Range, objDict As New Scripting.Dictionary
Dim strRange As String, objSheet As Worksheet
Set objSheet = Worksheets("Sheet1")
Set objCells = objSheet.Range("A1:" & objSheet.Cells.SpecialCells(xlCellTypeLastCell).Address)
For Each objCell In objCells
If objCell.MergeArea.Cells.Count > 1 Then
If Not objDict.Exists(objCell.MergeArea.Address) Then objDict.Add objCell.MergeArea.Address, ""
End If
Next
With objSheet
For i = 0 To objDict.Count - 1
strRange = objDict.Keys(i)
If .Range(strRange).Cells(1, 1).Value = "" Then
.Range(strRange).Cells(1, 1).Value = "-"
End If
Next
End With
End Sub
It may be a bit hard to see in the image but after running the macro, the merged cells that do not have a value are filled with a hyphen.
Not sure if it's necessary faster but it works and (I think) is fairly robust.