Could use some help on a project. My table looks something like this:
WEEK1 TEST1 VALUE
WEEK1 TEST1 [blank]
WEEK1 TEST2 [blank]
WEEK2 TEST1 VALUE
WEEK2 TEST2 [blank]
WEEK2 TEST1 VALUE
About 800 rows of these in different variations.
Now I need to find the first empty cell in C that has WEEK2 and TEST2 next to it. How would one go about doing this? Purpose is to enter a value in that cell that comes from a userform that defines A and B.
Sub FindMatch()
Dim sTxt1 As String, sTxt2 As String, vMatch As Variant
sTxt1 = """Week2"""
sTxt2 = """Test2"""
sformula = "MATCH(1,(A:A=" & sTxt1 & ")*(B:B=" & sTxt2 & "),0)"
vMatch = Evaluate(sformula)
If IsNumeric(vMatch) Then MsgBox Range("C" & vMatch).Address
End Sub
Added another condition to check whether Column-C is blank? Replace the below line of code to verify the column-C part also.
sformula = "MATCH(1,(A:A=" & sTxt1 & ")*(B:B=" & sTxt2 & ")*(C:C=""""),0)"
Try this code.
Sub CheckRows()
Dim RowNo As Long
RowNo = 1
With ActiveWorkbook.Sheets(1)
Do While .Cells(RowNo, 1).Value <> ""
If UCase(.Cells(RowNo, 1).Value) = "WEEK2" And _
UCase(.Cells(RowNo, 2).Value) = "TEST2" And _
.Cells(RowNo, 3).Value = "" Then
MsgBox "Found at Row Number " & RowNo
Exit Sub
Else
RowNo = RowNo + 1
End If
Loop
End With
End Sub
Sub test()
Dim x As Range, i&: i = [C:C].Find("*", , , , , xlPrevious).Row
For Each x In Range("A1:A" & i)
If UCase(x.Value2 & x.Offset(, 1).Value2 & _
x.Offset(, 2).Value2) = "WEEK2TEST2" Then
MsgBox x.Offset(, 2).Address(0, 0): Exit For
End If
Next x
End Sub
Related
I'm trying to copy some data from one Sheet to another using a vba script, it works fine but it doesn't appear to gather all the results, the data i have is split up over multiple tables so i assume it's seeing a blank space and stepping out but i'm not sure the solution! (the results i'm after are all letters i.e A-f and are all located on column C)
code below:
Sub copytoprint()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Application.ScreenUpdating = False
On Error GoTo Err_Execute
LSearchRow = 2
LCopyToRow = 2
While Len(Range("C" & CStr(LSearchRow)).value) > 0
If InStr(1, Range("C" & CStr(LSearchRow)).value, "A") > 0 Then
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Sheets("dest").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
Sheets("source").Select
End If
LSearchRow = LSearchRow + 1
Wend
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Input would just be a basic line of details i.e
ID person ref itemid itemname shape
Alphas1 bob A As01 Alphaselects1 circle
Alphas2 Stuart B As02 Alphaselects2 circle
Basically they are split up with many records I'd like it to grab all the A reference put them in one table then folow on with B C etc
Hope that makes a little sense?
Looks like you want to search from ActiveSheet using certain reference (A,B,C,,etc) and copy matching rows into unique destination sheets.
Below code will help you accomplish this, it separates the copying sub-procedure out into its own sub (called copyToSheet) and you can keep calling it from copytoprint() each time giving a reference and the destination sheet you desire.
Option Explicit
Private Sub copyToSheet(reference As String, shtSource As Worksheet, shtDest As Worksheet)
Dim x As Integer
Dim y As Integer
shtDest.Range("A2:Z" & shtDest.UsedRange.Rows.Count + 2).ClearContents
x = 2
y = 2
'loop until 20 consequtive rows have column C blank
While (Not shtSource.Range("C" & x).Value = "") _
And (Not shtSource.Range("C" & (x + 1)).Value = "") _
And (Not shtSource.Range("C" & (x + 5)).Value = "") _
And (Not shtSource.Range("C" & (x + 10)).Value = "") _
And (Not shtSource.Range("C" & (x + 20)).Value = "")
'If shtSource.Range("C" & x).Value, reference) > 0 Then
If shtSource.Range("C" & x).Value = reference Then
shtDest.Range("A" & y & ":Z" & y).Value = shtSource.Range("A" & x & ":Z" & x).Value
y = y + 1
End If
x = x + 1
Wend
End Sub
Public Sub copytoprint()
copyToSheet "A", ActiveSheet, Sheets("A")
copyToSheet "B", ActiveSheet, Sheets("B")
MsgBox "All matching data has been copied."
End Sub
So if I understood your problem correctly then you want to sort the data in sheet source first and then paste all of that data in another sheet.
If that's the case try this code.
Sub copytoprint()
Dim lastrow As Double
With Sheets("source")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A2:F" & lastrow).Sort key1:=Range("C3:C" & lastrow), order1:=xlAscending, Header:=xlNo
End With
Sheets("dest").Range("A2:F" & lastrow).Value = Sheets("source").Range("A2:F" & lastrow).Value
End Sub
I just can't work around this particular problem of mine where I have to concatenate all cells with data to a string, (e.g. " or ') in one column and then generate that concatenated result in another column.
Expected result:
Column A = ABCD
Column B = 'ABCD',
My Code
Option Explicit
Sub Concatenator ()
Columns("B") = "'" & Range(Range("A1"), Range("A1").End(xlDown)) & "',"
End Sub
I would put the code in a FOR Loop:
Sub Concatenator()
Dim lastLng As Long
lastLng = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
For x = 1 To lastLng
Cells(x, 2).Value = "'" & Cells(x, 1).Value & "',"
Next x
End Sub
Alternatively, if you don't want to use a loop, you can use the code below to paste your formula in column B:
Sub Concatenator()
Dim lastLng As Long
lastLng = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Range("B1:B" & lastLng).Formula = "=""'"" & A1 & "",'"""
End Sub
or you could use this
Sub Concatenator()
Range("A1", Cells(Rows.count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues).Offset(, 1).Formula = "=concatenate(""'"",RC[-1],""'"")"
End Sub
or this:
Sub Concatenator()
With Range("A1", Cells(Rows.count, 1).End(xlUp))
.Offset(, 1).Value = Application.Transpose(Split(Replace("'" & Join(Application.Transpose(.Value), "'|''") & "'", "'''", "''"), "|"))
End With
End Sub
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'm using Excel 2003 having the following table and want to remove the duplicate rows based on first name and last name if they are the same.
-------------------------------------
| first name | last name | balance |
-------------------------------------
| Alex | Joe | 200 |
| Alex | Joe | 200 |
| Dan | Jac | 500 |
-------------------------------------
so far i have a VB macro that only remove duplicates if the first name is duplicate.
Sub DeleteDups()
Dim x As Long
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).EntireRow.Delete
End If
Next x
End Sub
and please advice if it is possible to run this macro once the file opened.thanks in advance
You can use a dictionary to store the values. Any value already existing in the dictionary can be deleted during the iteration as well.
Code:
Sub RemoveDuplicates()
Dim NameDict As Object
Dim RngFirst As Range, CellFirst As Range
Dim FName As String, LName As String, FullName As String
Dim LRow As Long
Set NameDict = CreateObject("Scripting.Dictionary")
With Sheet1 'Modify as necessary.
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set RngFirst = .Range("A2:A" & LRow)
End With
With NameDict
For Each CellFirst In RngFirst
With CellFirst
FName = .Value
LName = .Offset(0, 1).Value
FullName = FName & LName
End With
If Not .Exists(FullName) And Len(FullName) > 0 Then
.Add FullName, Empty
Else
CellFirst.EntireRow.Delete
End If
Next
End With
End Sub
Screenshots:
Before running:
After running:
You can call this from a Workbook_Open event to trigger it every time you open the workbook as well.
Let us know if this helps.
Since you're working with Excel 2003, .RemoveDuplicates and COUNTIFs not supported, so you can try this one:
Sub DeleteDups()
Dim x As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim rngToDel As Range
'change sheet1 to suit
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For x = LastRow To 2 Step -1
If Evaluate("=ISNUMBER(MATCH('" & .Name & "'!A" & x & " & '" & .Name & "'!B" & x & ",'" & .Name & "'!A1:A" & x - 1 & " & '" & .Name & "'!B1:B" & x - 1 & ",0))") Then
If rngToDel Is Nothing Then
Set rngToDel = .Range("A" & x)
Else
Set rngToDel = Union(rngToDel, .Range("A" & x))
End If
End If
Next x
End With
If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub
this solution based on the formula =ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0)) with array entry, which returns TRUE if there're duplicates in rows above and FALSE othervise.
To run this macro just after opening workbook, add next code to ThisWorkbook module:
Private Sub Workbook_Open()
Application.EnableEvents = False
Call DeleteDups
Application.EnableEvents = True
End Sub
It works in excel 2007. Try in 2003 may be it'll help you
Sub DeleteDups()
Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Sheets("Sheet1").Range("A:A").SpecialCells(xlCellTypeConstants).Count, 3)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
End Sub
I'm noob on excel macros and I'm trying to make a macro like :
I want to input some number and compare it with value in A column
ex:
A column in excel have :
1234
1233
1236
and my input is:
1234
result :
B column
1 > 1234 - 1234 (find once)
0 > 1234 - 1233 (not same)
0 > 1234 - 1236 (not same)
C column
1233 > first value that not the same with input
1236 > second value that not the same with input
Right now i just know how to input the value :( something like this :
Sub getInput()
MyInput = InputBox("Enter Number")
MsgBox ("Searching") & MyInput
End Sub
I found the answer, so I will share
Sub getInput()
Dim i As Integer ' Integer used in 'For' loop
Dim x As Integer
Dim total As Integer
Dim save As Integer
Do
MyInput = InputBox("Enter Number")
If MyInput = "" Then
Exit Sub
Else
MsgBox ("Searching ") & MyInput
total = 0
x = 2
y = x + 1
For i = 1 To 3 'hardcode - 3 because I have 3 value in A
Cells(i, y).Value = ""
If Int(Cells(i, 1).Value) = Int(MyInput) Then
' A match has been found to the supplied string
' Store the current row number and exit the 'For' Loop
total = total + 1
If Cells(i, x).Value = 0 Then
Cells(i, x).Value = Int(total)
Else
Cells(i, x).Value = Int(Cells(i, x).Value) + Int(total)
End If
Else
Cells(i, y).Value = Cells(i, 1).Value
End If
Next i
' Pop up a message box to let the user know if the text
If total = 0 Then
MsgBox "String " & MyInput & " not found"
Else
MsgBox "String " & MyInput & " found"
End If
x = x + 1
End If
Loop Until MyInput = "" 'Loop until user press cancel or input blank data
End Sub
Tried by entering a value through inputbox to sheet first.
Hope it Helps
Sub Macro1()
Dim myformula As String
Dim lr As Long
With Sheets(1)
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Range("p1").Value = Application.InputBox("Enter Number", , , , , , 1)
Range("B1").Select
myformula = "=IF(R1C16=RC[-1],1,0)"
Range("b1").Formula = myformula
Selection.AutoFill Destination:=Range("B1:B" & lr), Type:=xlFillDefault
Range("C1").Select
ActiveCell.FormulaR1C1 = "=IF(C[-1]=0,C[-2],"""")"
Selection.AutoFill Destination:=Range("C1:C" & lr), Type:=xlFillDefault
End With
End Sub