Related
I have a code which performs different checks for 3 different columns. It works absolutely fine, but I want some alteration. Let’s see the code first.
Sub test()
On Error Resume Next
Dim cel As Range
Dim colCStr As String, colDStr As String, colEStr As String
Set ws = Sheets("Sheet1")
With ws
LastRow = .Cells(.Rows.count, "C").End(xlUp).row
For Each cel In .Range("C2:C" & LastRow)
'condition for Column C (cell not empty & characters in cell are alphabet)
For i = 1 To Len(cel)
If Not (Not IsEmpty(cel) And Asc(UCase(cel)) > 64 And Asc(UCase(cel)) < 91) Then
colCStr = colCStr & "," & cel.row
Exit For
End If
Next i
'condition for Column D (cell is numeric & length of cell value is 2 or 3)
If Not (IsNumeric(cel.Offset(0, 1)) And (Len(cel.Offset(0, 1)) = 2 Or Len(cel.Offset(0, 1)) = 3)) Then
colDStr = colDStr & "," & cel.Offset(0, 1).row
End If
'condition for Column E (cell is numeric & length of cell value is 7 or 8 or cell value is 0)
If Not (IsNumeric(cel.Offset(0, 2)) And (Len(cel.Offset(0, 2)) = 7 Or Len(cel.Offset(0, 2)) = 8) Or cel.Offset(0, 2) = 0) Then
colEStr = colEStr & "," & cel.Offset(0, 2).row
End If
Next cel
End With
'disply message box only if there's error
If Len(colCStr) > 0 Then
Sheets("Error_sheet").Range("A2" & row).Value = "Errors in Column C" & " : " & Mid(colCStr, 2, Len(colAStr))
If Len(colDStr) > 0 Then
Sheets("Error_sheet").Range("B2" & row).Value = "Errors in Column D" & " : " & Mid(colDStr, 2, Len(colDStr))
If Len(colEStr) > 0 Then
Sheets("Error_sheet").Range("C2" & row).Value = "Errors in Column E" & " : " & Mid(colEStr, 2, Len(colEStr))
Else
End If
End If
End Sub
The code performs following checks:
Column C: Cell not empty & characters in cell are alphabet (Actually I don’t want to perform any checks over here in Column C, but if I delete the lines of code which validate Column C the rest of code stops getting executed too).
Column D: Cell is numeric & length of cell value is 2 or 3 (I want the absolutely same checks).
Column E: Cell is numeric & length of cell value is 7 or 8 or cell value is 0 (I want the absolutely same checks).
I appreciate your time and efforts.
This version doesn't use Offset so it should be easier to update (and more efficient)
Option Explicit
Public Sub CheckColDandE()
Dim ws As Worksheet, lr As Long, arr As Variant, r As Long
Dim dOk As Boolean, eOk As Boolean, dErr As String, eErr As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
arr = ws.Range("D2:E" & lr)
For r = 1 To lr - 1
dOk = IsNumeric(arr(r, 1)) And arr(r, 1) > 9 And arr(r, 1) < 1000
eOk = IsNumeric(arr(r, 2))
eOk = eOk And (arr(r, 2) > 999999 And arr(r, 2) < 100000000 Or arr(r, 2) = 0)
If Not dOk Then dErr = dErr & r + 1 & ", "
If Not eOk Then eErr = eErr & r + 1 & ", "
Next
With ws.Range("D" & lr + 1 & ":E" & lr + 1)
.Value2 = vbNullString
If Len(dErr) > 0 Then .Cells(1) = "Rows with Errors: " & Left(dErr, Len(dErr) - 2)
If Len(eErr) > 0 Then .Cells(2) = "Rows with Errors: " & Left(eErr, Len(eErr) - 2)
End With
End Sub
Delete the following lines (and update your comments! The column names in comments and code ae not the same):
'condition for Column A (cell not empty & characters in cell are alphabet)
For i = 1 To Len(cel)
If Not (Not IsEmpty(cel) And Asc(UCase(cel)) > 64 And Asc(UCase(cel)) < 91) Then
colCStr = colCStr & "," & cel.row
Exit For
End If
Next i
I'm trying to create a module with a for loop to count the unique values of 3 combining columns containing the status of payment day, the month and the year of a date. Said date is separated because each of them refer to a cycle of the month and everything is sorted by year, month and day in this exact order. Like the simplified small example below.
STATUS: DAY : MONTH : YEAR
PAID: 1 : 7 : 2016
OPEN: 1 : 7 : 2016
PAID: 1 : 7 : 2016
OPEN: 5 : 7 : 2016
PAID: 5 : 7 : 2016
OPEN: 5 : 7 : 2016
PAID: 10 : 7 : 2016
OPEN: 10 : 7 : 2016
PAID: 10 : 7 : 2016
PAID: 15 : 7 : 2016
PAID: 15 : 7 : 2016
OPEN: 15 : 7 : 2016
What i tried to do was to compare all 3 cells with the next cell of the columns, if they were equal in all 3 cases i would simply count it to see how many unique values i had of this date and save it on a separate sheet. If it is different in any of cases it would simply add the date to the second sheet and start counting from there. The code below is simplified for convenience and because the macro i'm working on is way too big to post here.
EDIT: If needed i can post upload the complete code somewhere, i'll just to translate some of the variables and comments.
j = 3 '' variable referencing the next line after i
k = 1 '' variable referencing the lines of the second sheet.
For i = 2 To lastrow ''variable to count how many rows the first sheet has
j = j + 1 ''variable to check the very next line after i
If w1.Range("A" & i).Value = "PAID" Then
If w1.Range("H" & i).Value = w1.Range("H" & j) And w1.Range("G" & i).Value = w1.Range("G" & j) And w1.Range("F" & i).Value = w1.Range("F" & j) Then ''if statement to check if all 3 cells are equal to the next 3 cells
w2.Range("D" & K).Value = w2.Range("D" & K).Value + 1 '' Sum 1 to the total number of dates with equal parameters on the 3 cells
Else '' writes the new date in the second sheet
K = K + 1
w2.Range("A" & K).Value = w1.Range("H" & i).Value
w2.Range("B" & K).Value = w1.Range("G" & i).Value
w2.Range("C" & K).Value = w1.Range("F" & i).Value
w2.Range("D" & K).Value = 1
End If
End If
Next i
What i get is usually the first date with everything counted on a single line in the new sheet and the very data of the very last row in the second line.
I also tried to use dictionaries and/or collections but i didn't quite get the concept of them even on some examples i have found on stack overflow and on the internet.
How do i make this loop work or what would be a better way to do this?
To get the unique combinations from 4 columns:
Sub uniKue()
Dim i As Long, N As Long, s As String
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
Cells(i, 5) = Cells(i, 1) & " " & Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)
Next i
Range("E2:E" & N).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
NOTE:
You can extend the approach for as many columns as needed:
concatenate the columns
use the RemoveDuplicates feature in the Ribbon's Data tab
EDIT#1:
This version:
Sub uniKue()
Dim i As Long, N As Long, s As String, r As Range
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
Cells(i, 5) = Cells(i, 1) & " " & Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)
Cells(i, 6) = Cells(i, 5)
Next i
Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In Range("F:F").SpecialCells(2).Offset(, 1)
r.Formula = "=COUNTIF(E:E," & r.Offset(, -1).Address & ")"
Next r
End Sub
Produces:
Column E is the full combination set.Column F is the unique set.Column G is the number of occurrences of each unique item.Once completed, column E can be hidden.
To get the number of distinct rows (8), this Excel Formula can be used (in VBA too):
=SUMPRODUCT(1 / COUNTIFS(A2:A13,A2:A13, B2:B13,B2:B13, C2:C13,C2:C13, D2:D13,D2:D13) )
To get the number of unique rows that don't have duplicates (4):
=SUMPRODUCT(--( COUNTIFS(A2:A13,A2:A13, B2:B13,B2:B13, C2:C13,C2:C13, D2:D13,D2:D13)=1 ))
In VBA, Excel formulas can be calculated with the Evaluate method:
lastRow = Sheet1.Cells.CurrentRegion.Rows.Count
uniqueCount = Sheet1.Evaluate(Replace( _
"SUM(--(COUNTIFS(A2:A3,A2:A3,B2:B3,B2:B3,C2:C3,C2:C3,D2:D3,D2:D3)=1))", 3, lastRow))
Debug.Print uniqueCount ' 4
You can also get the counts of all rows at once (faster than calling Excel for each cell separately):
countsArray = Sheet1.Evaluate(Replace( _
"Transpose(CountIfs(A2:A9,A2:A9,B2:B9,B2:B9,C2:C9,C2:C9,D2:D9,D2:D9))", 9, lastRow))
' Debug.Print Join(countsArray) ' "2 1 2 2 1 2 2 1 2 2 2 1"
' Debug.Print Evaluate("SUM(--({" & Join(countsArray, ",") & "}=1))") ' 4
' Debug.Print Evaluate("SUM(1/{" & Join(countsArray, ",") & "})") ' 8
For i = 2 To lastRow
If countsArray(i - 1) = 1 Then
' ... no dumplicates
Else
' .. has duplicates
End If
Next i
Iam new to Excel VBA , I am started writing a code , which was executed fine, but I need a suggestion how to write a function where i dont need to write code for all "ID".
For example :
I have main works sheet having ID(1000x, 10000, 2000X,20000).
I want to search only ID with number not with alphabet, and compare it with another worksheet , having the same ID , if then get the corrosponding ID 3rd column data and conacdenate all them into main worksheet .
I have main worksheet ("Tabelle1")having all the ID(10000,20000) in Coloumn A ,I want the infomration of ID 10000 in column B of ID 10000. some times i have 10000 for four times . Want to paste infomration to another worksheet ("Test_2"), I want to collect all the 10000 and corrosponding data .
Sub Update()
If MsgBox("Are you sure that you wish to Update New Measurement ?", vbYesNo, "Confirm") = vbYes Then
Dim erow As Long, erow1 As Long, i As Long
erow1 = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To erow1
If Sheets("Tabelle1").Cells(i, 2) <> "10000" Then
Sheets("Tabelle1").Range(Sheets("Tabelle1").Cells(i, 1), Sheets("Tabelle1").Cells(i, 2)).Copy
Sheets("Test_2").Activate
erow = Sheets("Test_2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets("Test_2").Range(Cells(erow, 1), Cells(erow, 2))
Sheets("Test_2").Activate
End If
Next i
Application.CutCopyMode = False
For i = 1 To erow
Totalstrings = Totalstrings & Cells(i, 2) & "" + vbCrLf
Next i
Totalstrings = Left(Totalstrings, Len(Totalstrings) - 1)
Range("C5") = Totalstrings
Range("C5").Select
Selection.Copy
Sheets("BSM_STF_iO").Select
Range("C5").Select
ActiveSheet.Paste
MsgBox "New measurements have been Updated !"
End If
End Sub
Example
In BSM:STM:IO
A B
ID
1000X
10000
10001
...
in Tabelle1
B C
ID
1000 abc
1000 xyz
10001 lmn
2000 def
"
I want to compare only digit from"the "BSM:STM:Io" with "tabelle1". Example take the the first value 10000 from "BSM_STM_io" compare with tabele take the the value of corrosponding Coloumn "C" in "tablle1" and put it into single cell in 1000 of BSM_STM:Io
A , B , C are coloumn in the worksheet
enter image description here
Lets assume worksheet "BSM_STF_iO" contains the ID information in A column beginning with A2 and worksheet Tabelle1 contains the required concaetenation information in B Column beginning from B2 (ex: Column B: IDs, Column C: information to concaetenate). Below code will concaetenate the contents and write in BSM_STF_iO sheet.
Sub test1()
Worksheets("BSM_STF_iO").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(Range("A" & i).Value)
With Worksheets("Tabelle1")
destlastrow = .Range("B" & Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
If a = Trim(.Range("B" & j).Value) Then
If out <> "" Then
out = out & ", " & .Range("C" & j).Value
Else
out = .Range("C" & j).Value
End If
End If
Next j
Cells(i, 2) = out
out = ""
End With
Next i
End Sub
and below function taken from How to find numbers from a string?
Function onlyDigits(s As String) As String
Dim retval As String
Dim i As Integer
retval = ""
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
onlyDigits = retval
End Function
I have a VBA code that calculates a formula (I know it's pretty long):
Cells(i, mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C3,3,0))))"
in the Vlookup it takes a 4th column in the range from C1:C4 and the 3rd column from the range C1:C3.
It was ok till the column number (4 and 3) was fixed.
Now it changes each time running For cycle.
Foe example, the second run column numbers will be 5 and 4, the third run 6 and 5 and so on till 12.
Is there any way to integrate the column number changed dynamically into the formula above?
Thanks a lot!
I put also a whole code as well.
Sub AutoCalcV2()
Dim ws As Worksheet
Dim LastRow As Long
Dim i As Integer, n As Integer, x As Integer, j As Integer, mcol As Integer
Set ws = ActiveWorkbook.Sheets("Sheet1")
ws.Select
LastRow = Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
mcol = 71
For j = 1 To 11
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C3,3,0))))"
Range("BT4").Select
Next i
Next j
End Sub
Dim iColumn as Integer
mcol = 71
For j = 1 To 11
iColumn = 4
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4," & str(iColumn) & ",0)),SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4," & str(iColumn) & ",0)),(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C3,3,0))))"
Range("BT4").Select
iColumn = iColumn + 1
Next i
Next j
So based on what I understood, you have 3 vlookups and you want to use 4 (4+1,5+1,6+1) for first Two vlookups and 3 (3+1,4+1,5+1) for third one.
If that so, here how you can increment your 4 and 3.
Sub AutoCalcV2()
Dim ws As Worksheet
Dim LastRow As Long
Dim i, n, x, j, mcol, iCol As Integer '<-- Changed here
Set ws = ActiveWorkbook.Sheets("Sheet1")
ws.Select
LastRow = Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
mcol = 71
iCol = 4 '<-- Newly added
For j = 1 To 11
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
'Changed the formula
Cells(i, mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))" & _
"*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4," & iCol & ",0)),SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))" & _
"*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4," & iCol & ",0)),(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))" & _
"*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C3," & i & ",0))))"
Range("BT4").Select
iCol = iCol + 1
Next i
Next j
End Sub
OK, Take a look. I can give an suggestion for you. Not the whole formula, Just a part of VLOOKUP.
I know that this is your formula for cell in loop:
Cells(i, mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C4,4,0)),(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))*(VLOOKUP('Sheet1'!RC66,GA_C!C1:C3,3,0))))"
Now is you want to change the dynamically the column according to looping. I understand the column pair as follow:
C1:C4 & C1:C3
C1:C5 & C1:C4
C1:C6 & C1:C5
C1:C7 & C1:C6
C1:C8 & C1:C7
C1:C9 & C1:C8
C1:C10 & C1:C9
C1:C11 & C1:C10
C1:C12 & C1:C11
Actually, your looping are not clear, I can't use it. So, I used as follow:
For column = 3 To 11
mcol = mcol + 1
For row = 1 To lastRow
Cells(row , mcol) = "=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C66,RC66))*" & _
"(VLOOKUP('Sheet1'!RC66,GA_C!C1:C" & column + 1 & "," & column + 1 & ",0))" & _
",SUM((RC[-3]/SUMIFS(C[-3],C66,RC66))*" & _
"(VLOOKUP('Sheet1'!RC66,GA_C!C1:C" & column + 1 & "," & column + 1 & ",0))" & _
",(RC[-3]/SUMIFS(C[-3],C66,RC66,C[-1],""GA + C""))*" & _
"(VLOOKUP('Sheet1'!RC66,GA_C!C1:C" & column & "," & column & ",0))))"
Next row
Next column
Try as above, it will be helpful for you.
I have an excel sheet of which the data was jumbled: for example, the data that should have been in Columns AB and AC were instead in Columns B and C, but on the row after. I have the following written which moved the data from B and C to AB and AC respectively:
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("A:A")
i = 1
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each rCell In rRng.Cells
If rCell.Value = "" Then
Range("AB" & i) = rCell.Offset(0, 1).Value
rCell.Offset(0, 1).ClearContents
End If
i = i + 1
If i = lastRow + 1 Then
Exit Sub
End If
Next rCell
End Sub
However, it doesn't fix the problem of the data being on the row BELOW the appropriate row now that they are in the right columns. I am new to VBA Macros so I would appreciate any help to make the data now align. I tried toggling the Offset parameter (-1,0) but it's not working.
Try something like this?
For i = Lastrow To 1 Step -1
' move data into cell AA from Cell A one row down
Cells(i, 27).Value = Cells(i + 1, 1).Value
Next
You don't need to loop through the range to accomplish what you're trying to do.
Try this instead:
Sub MoveBCtoAbAcUpOneRow()
Dim firstBRow As Integer
Dim lastBRow As Long
Dim firstCRow As Integer
Dim lastCRow As Long
' get the first row in both columns
If Range("B2").Value <> "" Then
firstBRow = 2
Else
firstBRow = Range("B1").End(xlDown).Row
End If
If Range("C2").Value <> "" Then
firstCRow = 2
Else
firstCRow = Range("C1").End(xlDown).Row
End If
' get the last row in both columns
lastBRow = Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row
lastCRow = Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
' copy the data to the correct column, up one row
Range("B" & firstBRow & ":B" & lastBRow).Copy Range("AB" & firstBRow - 1)
Range("C" & firstCRow & ":C" & lastCRow).Copy Range("AC" & firstCRow - 1)
' clear the incorrect data
Range("B" & firstBRow & ":B" & lastBRow).ClearContents
Range("C" & firstCRow & ":C" & lastCRow).ClearContents
End Sub
Notes:
If the shape of data in each column is the same, you don't need to
find the first and last row for each. You'll only need one variable for each and one copy operation instead of 2.
Make sure you set variable declaration to required.
(Tools -> Options -> Require Variable Declaration) You may already be doing this, but I couldn't tell because it looks like the top of your Sub got truncated.