I have written this code to eliminate columns based on header names. On one workbook I have the list of headers to delete, and on the other workbook I have the columns themselves.
'setup
Dim nominas_ws As Worksheet
Set nominas_ws = ActiveSheet
Dim conceptos_wb As Workbook
Set conceptos_wb = Workbooks.Open("C:\Users\deepw\Desktop\nominas\conceptos.xlsx")
Dim conceptos_ws As Worksheet
Set conceptos_ws = conceptos_wb.Worksheets(1)
Dim nominas_last_row, nominas_last_column, conceptos_last_row, conceptos_last_column As Long
nominas_last_row = nominas_ws.Cells(Rows.Count, 5).End(xlUp).Row
nominas_last_column = nominas_ws.Cells(1, Columns.Count).End(xlToLeft).Column
conceptos_last_row = conceptos_ws.Cells(Rows.Count, 5).End(xlUp).Row
conceptos_last_column = conceptos_ws.Cells(1, Columns.Count).End(xlToLeft).Column
'delete names & unwanted columns
nominas_ws.Range("C2:C" & nominas_last_row).ClearContents
Dim conceptos_headers As Range
Dim i, c As Integer
Dim concepto_input As String
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = 1 To nominas_last_column
If Cells(c, 1).Value = "concepto_input" Then Cells(c, 1).EntireColumn.delete
Next c
Next i
Thank you in advance for your help.
If Cells(c, 1).Value = "concepto_input" Then
you are checking for the string literal "concepto_input", not the value in the variable concepto_input. Should be:
If Cells(c, 1).Value = concepto_input Then
If there might be multiple matches for any given column heading, you should loop backwards:
For i = 2 To conceptos_last_row
concepto_input = conceptos_ws.Cells(i, 1).Value
For c = nominas_last_column To 1 Step -1
If conceptos_ws.Cells(c, 1).Value = concepto_input Then
conceptos_ws.Columns(c).Delete
'Exit For 'if there can only be one match per search term
End If
Next c
Next i
Note it's also good practise to never use Range/Cells without an explicit worksheet qualifier.
Related
Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.
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
The code below works fine on its own but once i add option explicit at the start, the object variable or with block variable not set error appears at the sheetname = index3. I have seen other threads where the issue is solved by set sheetname = ThisWorkbook.Worksheets("") but there are 3 sheets that will be created before i used this statement so i don't think it can work that way. Any ideas to solve this?
Option explicit
Private Sub createvramp()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As Worksheet
Dim indexrowcount As Integer
j = 2
iRow = 1
lastline = ActiveSheet.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 99 ' Max Group Size with Same name in F to H column
count = 1
If Cells(iRow, "H").Value = "Vramp_M1" Then
sheetname = "Index1"
ElseIf Cells(iRow, "H").Value = "Vramp_M2" Then
sheetname = "Index2"
Else
sheetname = "Index3" '<-------error occurs here
End If
For aRow = a To b
If Cells(iRow, "H") = Cells(aRow, "H") And Cells(iRow, "I") = Cells(aRow, "I") And Cells(iRow, "J") = Cells(aRow, "J") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":AP" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count + 1
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
If you just want to set the sheet name in your code, use Dim sheetname As String. Option Explicit helps a lot, but you must be very careful when you declare variables...
It happened that the error to appear on that row only because the first two conditions were False...
It is also good to avoid using of ActiveSheet, Sheets(...), Range("A" ...), Cells(aRow,...).
Everything expressed in this way refers to ActiveSheet. When you will work on a different sheet, maybe on a different workbook and you need to process a specific sheet (Sheets(sheetname).Range...), you may face a big mess. Try to define the sheet with reference to its workbook. Each range to reference the sheet where it belongs...
At least Dim Sh as Worksheet followed by Set Sh = ActiveSheet (use your working sheet). And then use Sh.Range("A...), Sh.Cells(aRow,...) and so on...
It is recommended to cultivate good habits which will help you in the future...
Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?
Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
I am having an issue getting array values to compare to values stored in cells on the spreadsheet.
I have tried having the cell value compare directly to the array value, but the check fails every time.
To attempt to correct this issue I have tried assigning the cell value on each iteration to a variable dimmed as varient (Just as the array is dimmed a varient)
Values are added to the array successfully and the varient type is used as some invoices are numbers only while others include letters.
When I walk through my code the variable is not being assigned/accepting a value. Every time the comparison statement is reached the variable shows that it is empty.
Dim Paidlrow As Long
Dim lrow As Long
Dim wb As Workbook
Dim Consolid As Worksheet
Dim PaidInv As Worksheet
Dim Summary As Worksheet
Dim Invoices() As Variant
Dim InvCheck As Variant
Dim txt As String
Dim Formula As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim Cleared As Long
Dim LInv As Long
Dim NewBlank As Long
Dim MaxSheets As Integer
Set wb = Workbooks("Wire Payments projections for Euro's")
Set Consolid = wb.Sheets("Consolidation")
Set Summary = wb.Sheets("Pay Summary")
Set PaidInv = wb.Sheets("Paid Invoices")
'define define and define
MaxSheets = wb.Sheets.Count
lrow = Consolid.Cells(Rows.Count, 1).End(xlUp).Row + 1
Cleared = 1
ReDim Preserve Invoices(1 To Cleared)
i = 2
With wb
'begin inv extraction loop
For i = 2 To lrow
ReDim Preserve Invoices(1 To Cleared)
'if inv is marked for payment, add to array and move details to paid inv tab
With PaidInv
Paidlrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
With Consolid
If .Cells(i, 10) = "X" Or .Cells(i, 10) = "x" Then
Invoices(Cleared) = .Cells(i, 1)
Consolid.Rows(i).Copy Destination:=PaidInv.Cells(Paidlrow, 1)
Consolid.Rows(i).Clear
Cleared = Cleared + 1
End If
End With
Next i
End With
'loop through each sheet to remove paid invoices identifie in previous loop
For k = 1 To MaxSheets
If wb.Sheets(k).Name <> Summary.Name And wb.Sheets(k).Name <> PaidInv.Name And wb.Sheets(k).Name <> Consolid.Name Then
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
For j = LBound(Invoices) To UBound(Invoices)
For l = 7 To LInv
InvCheck = .Cells(l, 2).Value
If Invoices(j) = InvCheck And InvCheck <> "" Then
'.Rows(l).Delete
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A7:K7").Copy
.Range(.Cells(NewBlank, 1), .Cells(NewBlank, 11)).PasteSpecial Paste:=xlPasteFormats
'.Cells(NewBlank, 1) = Right(.Cells(1, 9), 6)
'Formula = "=$B$3*I"
'Formula = Formula & NewBlank
'.Cells(NewBlank, 10).Formula = Formula
End If
Next l
Next j
End With
End If
Next k
I have commented out code for the ease of testing. With the way it is now it should format some additional cells to match the formatting above it.
UPDATE
For kicks and giggles, I changed the Array and associated variable check to String type rather than variant. For some reason, this fixed the issue I was having. I am so confused...
There seems to be a dot missing:
With wb.Sheets(k)
LInv = Cells(Rows.Count, 2).End(xlUp).Row + 1
should be:
With wb.Sheets(k)
LInv = .Cells(Rows.Count, 2).End(xlUp).Row + 1
to ensure that LInv is read from sheet number k.
As it is, the code is equivalent to:
With wb.Sheets(k)
LInv = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1
and, if the active sheet doesn't have any values in the cells you are looking at, the comparison will fail.
There's a similar issue with this line later on in the code:
NewBlank = Cells(Rows.Count, 1).End(xlUp).Row + 1
should be:
NewBlank = .Cells(Rows.Count, 1).End(xlUp).Row + 1