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
Related
here is my case :
Column A is empty.
Column B is the room number of a guest
Column C is the Name of the guest in that room
I am trying to count how many room are occupied. so I put a count formula but the Result is 0. I don't know why..
Here is the code:
Sheets("Champagne").Select
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("A2").End(xlDown).Row
Cells(LastRow + 2, "A").Formula = "=SUM(A2:A" & LastRow & ")"
LRowA = [A4200].End(xlUp).Address
Range("A:A").Interior.ColorIndex = xlNone
Range("A2:" & LRowA).Interior.ColorIndex = 33
Range("A:A").HorizontalAlignment = xlCenter
so then I was trying to put a formula to say if Column B as any Number (the room number), it will count as 1 in the column A. And then put a Sum at the end of Column A.
Here is the code that I am trying to put but it puts 123456 in the column C.
Sheets("Champagne").Select
For Each Cel In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
If Cel.Value <> "" Then Cel.Offset(1, 0).Value = "123456"
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("A2").End(xlDown).Row
Next
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("A2").End(xlDown).Row
Cells(LastRow + 2, "A").Formula = "=SUM(A2:A" & LastRow & ")"
LRowA = [A4200].End(xlUp).Address
Range("A:A").Interior.ColorIndex = xlNone
Range("A2:" & LRowA).Interior.ColorIndex = 33
Range("A:A").HorizontalAlignment = xlCenter
If you have an answer with the first code, I take it as well....
To count how many rooms (column B) are occupied I would use code like:
Function CountOccupiedRooms(sheetname As String) As Long
Dim j As Long
dim c As Range
With Worksheets(sheetname)
'Check that some data exists
If IsEmpty(.Range("B2").Value) Then
CountOccupiedRooms = 0
Exit Function
End If
For Each c In .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
If Application.WorksheetFunction.CountIf(.Range("B2:B" & c.Row), c.Value) = 1 Then
j = j + 1
End If
Next
End With
CountOccupiedRooms = j
End Function
and then, assuming you wanted to put that number in a cell somewhere, that code could be called in your main code as
Worksheets("Summary").Range("C5").Value = CountOccupiedRooms("Champagne")
Worksheets("Summary").Range("C6").Value = CountOccupiedRooms("ChocoStrawb")
The destination worksheet name ("Summary") and the locations ("C5" and "C6") were just made up for illustration purposes - you can use whatever you like.
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
I want vba code to look for specific ranges of data if these data exist in main sheet then retrieve last row of data that mean based on conditions. For example(there are 3 row with "dler" I want to compare dler with three rows of second sheet if all exist retrieve the row of dler) that mean compare name with other rows and so on... The picture is two sheets the first one is (main sheet) and the second one is the table that the vba work on it to find data in (main sheet) I have this code but I don't know how change it to work with dynamic records.
Main and Search Worksheet Image
Sub Matching_name()
Dim a_name As String, i As Long, j As Long, Last_Row As Long
For i = Last_Row To 2 Step -1
a_name = Cells(i, "B").Value
If City = "dler" Then
'Set the range destination, Range(“A2”), depending on which
'range you want in Sheets(“Remaining”)
Rows(i).EntireRow.Copy Destination:=Worksheets("Remaining").Range("A1")
Exit For
End If
Next i
End Sub
This will copy the last matching rows
Sub Matching_name()
Dim i As Long, j As Long, k As Long, Last_Row As Long, temp As Long
Dim a_name As String, s_type As String, c_type As String
temp = 1
Last_Row = 6
For i = 2 To Last_Row
Worksheets("Main Sheet").Activate
a_name = Cells(i, 2).Value
s_type = Cells(i, 5).Value
c_type = Cells(i, 6).Value
Worksheets("Search Sheet").Activate
For j = 1 To 3
If Cells(j, 1).Value = a_name And Cells(j, 2).Value = s_type And Cells(j, 3).Value = c_type Then
Worksheets("Main Sheet").Activate
Rows(i & ":" & i).Select
Selection.Copy
Worksheets("Remaining").Activate
Rows(temp & ":" & temp).Select
ActiveSheet.Paste
temp = temp + 1
End If
Next j
Next i
Worksheets("Remaining").Activate
For x = temp To 1 Step -1
y = 1
While y <= temp
If Cells(y, 2).Value = Cells(x, 2).Value And x <> y Then
Rows(y & ":" & y).Delete
y = y - 1
temp = temp - 1
End If
y = y + 1
Wend
Next x
End Sub
I am trying to create VBA code that copies and pastes data from Column B into the row directly beneath in Column A. I do not have great experience with VBA and so I am struggling to create such a code.
I would like to create a code that loops for an entire set of data in Columns A and B as shown in the attached picture.
So for example, B3 would get pasted into A4. B5 would get pasted into A6. And all the way down until the list was completed.
Thank you for any help!
The below code works quite good for your criteria.
rowNum = 3
Do While Trim(Range("A" & rowNum).Value) <> ""
Range("A" & (rowNum + 1)).Value = Range("B" & rowNum).Value
rowNum = rowNum + 2
Loop
Here is a simple example that will do what you ask.
For i = 2 To 10
If Range("A" & i) > "" And Range("A" & i + 1) = "" Then
Range("B" & i).Cut
Range("A" & i + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If
Next
Depending on what your data looks like, you will probably want to setup something more dynamic for the value of 'i'.
Use LastRowIndex from https://stackoverflow.com/a/71296/42346 to find the final row then iterate over the rows in column 2 placing the value in column 1 one row below the current row.
Sub iterate()
Dim r As Long
Dim c As Long
Dim endrow As Long
c = 2
endrow = LastRowIndex(ActiveSheet, c)
For r = 2 To endrow Step 1
If ActiveSheet.Cells(r, c).Value <> "" Then
ActiveSheet.Cells(r + 1, c - 1).Value = ActiveSheet.Cells(r, c).Value
End If
Next r
End Sub
Function LastRowIndex(ByVal w As Worksheet, ByVal col As Variant) As Long
Dim r As Range
Set r = Application.Intersect(w.UsedRange, w.Columns(col))
If Not r Is Nothing Then
Set r = r.Cells(r.Cells.Count)
If IsEmpty(r.Value) Then
LastRowIndex = r.End(xlUp).Row
Else
LastRowIndex = r.Row
End If
End If
End Function
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