Form Data to Particular Cells - vba

In Excel sheet2 i have Columns A & D for Name, B & E Start Date and column C & F is End Date and a Form with ComboBox (loaded with names) and two Textboxes.
I want when I click submit button it will search the columns for a name that matches the ComboBox value and then write the values of the two TextBoxes into the right adjacent two EMPTY cells
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Me.Combo.Value
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = Me.sttdate.value
.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Value = Me.enddate.Value
End With
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
End Sub
This code is adding value of all form into Columns A B & C

This should do the trick. I added some checks based on what you wrote in your explanation in case it helps.
Private Sub CommandButton4_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
With ws
irow = .Range("A" & .Rows.Count).End(xlup).Row
Dim rFound as Range
Set rFound = .Range("A1:A" & iRow).Find(Me.Combo.Value, lookat:=xlWhole)
If not rFound is Nothing Then
If IsEmpty(rFound.Offset(,1)) and IsEmtpy(rFound.Offset(,2)) Then
rFound.Offset(,1) = Me.sttdate.value
rFound.Offset(,2) = Me.enddate.value
With Me
.Combo.Value = ""
.startdate.Value = ""
.enddate.Value = ""
End With
Else
Msgbox "Name already has values"
End If
Else
Msgbox "Name not Found"
End If
End Sub

This should work just fine :
Private Sub CommandButton4_Click()
Dim irow As Long, _
wS As Worksheet, _
NextRow As Long, _
cF As Range
Set wS = Worksheets("Sheet2")
With wS
With .Range("A:A")
'First, define properly the Find method
Set cF = .Find(What:=Me.Combo.Value, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
End With
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
If cF.Offset(0, 1) <> vbNullString Then
Set cF = cF.End(xlToRight).Offset(0, 1)
cF.Value = Me.sttdate.Value
cF.Offset(0, 1).Value = Me.EndDate.Value
Else
.Cells(cF.Row, "B").Value = Me.sttdate.Value
.Cells(cF.Row, "C").Value = Me.EndDate.Value
End If
Else
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
.Cells(NextRow, "A").Value = Me.Combo.Value
.Cells(NextRow, "B").Value = Me.sttdate.Value
.Cells(NextRow, "C").Value = Me.EndDate.Value
End If
End With
With Me
.Combo.Value = ""
.StartDate.Value = ""
.EndDate.Value = ""
End With
End Sub

Related

Conflicting DATA - Duplicated values

I created a macro that fills the missing Data with specific Data from another sheet , the codes works perfectly in copying pasting data from excel of the client and prepare the data needed to start the work but the only problem here below
Code:
With Worksheets("Feuil2")
' reference "target" sheet (change "Target" to our actual target sheet name)
With .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) 'reference
its column B range from row 1 down to last not empty one
If WorksheetFunction.CountBlank(.Cells) > 0 Then
' if any blank cell in referenced range. this check to avoid error thrown by subsequent
statament
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=index(GDC!" & rng.Offset(, 1).Address(, , xlR1C1) & ",match(RC[-1],GDC!" & rng.Address(, , xlR1C1) & ",0))" 'fill blank cells with a lookup (well, sort of) formula
.Value = .Value 'get rid of formulas and leave values only
Cells.Select
End If
End With
End With
This code works perfectly in matching and filling data but when for e.g find a duplicated value it copy only the first value not the second one
See the image below to better understand the main problem :
As you can see in the image The problem that in column A i may have data repeated twice like this value P20845 which in column F it is repeated one with the name of Ghaith and the other with the name of sirine but as you can see in the column A it is just with the name also of Ghaith and there is no name of sirine
Anyidea or better solution in solving this and getting all the needed DATA? .
Best Regards
POLOS
Or use a dictionary
Option Explicit
Public Sub AddValues()
Application.ScreenUpdating = False
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet, masterDict As Object, arr() As Variant, i As Long, rng As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Feuil1")
Set wsTarget = wb.Worksheets("Feuil2")
Set masterDict = CreateObject("Scripting.Dictionary")
With wsSource
arr = Intersect(.Columns("A:B"), .UsedRange)
For i = 1 To UBound(arr, 1)
If Not masterDict.exists(arr(i, 1)) Then masterDict.Add arr(i, 1), GetAllMatches(arr(i, 1), arr(i, 2), wsSource)
Next i
End With
With wsTarget
For Each rng In Intersect(.Columns("A"), .UsedRange)
On Error Resume Next
rng.Offset(, 1) = masterDict(rng.Value)
On Error GoTo 0
Next rng
End With
Application.ScreenUpdating = True
End Sub
Public Function GetAllMatches(ByVal findString As String, ByVal dupString As String, ByVal searchRng As Worksheet) As String
Dim foundCell As Range
Dim concatenatedString As String
concatenatedString = vbNullString
With Intersect(searchRng.Columns(1), searchRng.UsedRange)
Set foundCell = .Find(findString)
If foundCell Is Nothing Then Exit Function
If Not foundCell Is Nothing Then concatenatedString = foundCell.Offset(, 1)
Dim currMatch As Long
currMatch = 0
For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)
Set foundCell = .Find(What:=findString, After:=foundCell, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not foundCell Is Nothing And InStr(1, dupString, concatenatedString) = 0 Then
concatenatedString = concatenatedString & "/" & foundCell.Offset(, 1)
Else
concatenatedString = foundCell.Offset(, 1)
End If
Next currMatch
End With
GetAllMatches = concatenatedString
End Function
Output in Feuil2
Maybe something like this instead?
Sub Test()
Dim i As Long, myrow As Long, lastrow As Long
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lastrow = 1
For i = 1 To 7
If Application.WorksheetFunction.CountIf(sht1.Range("A:A"), sht2.Range("F" & i).Value) = 0 Then
If i = 1 Then
lastrow = 1
Else
lastrow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row + 1
End If
sht1.Range("A" & lastrow).Value = sht2.Range("F" & i).Value
sht1.Range("B" & lastrow).Value = sht2.Range("G" & i).Value
Else
sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value = sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value & "/" & sht2.Range("G" & i).Value
End If
Next i
End Sub

Excel VBA, Show comments on new sheet if the cell it is in is visible

The title was hard to keep true to what I need in full so please read all the text.
I am trying to use a button to create a sheet that will show users all the comments on all the worksheets in an easy to understand format that basically acts as the highlights of the workbook.
The issue is the code currently shows ALL comments but I only wish for the person to see currently visible comments. What do I mean? Not all users can see all sheets or all columns and rows. Certain data is hidden because it does not pertain to them. I only want them to see data that is currently visible on any sheet they have as visible.
Example (NOT A REAL SITUATION); an excel document has 3 sheets (Sheet1, Sheet2, Sheet3). John logs in (using a Select Case VBA that hides data he does not need) and can see Sheet1 and Sheet2 but cannot see specific rows in each sheet such as Row 2 and column F in Sheet1 and Row 5 and Column K in Sheet2. He does not need to see the comments for the rows, columns, and sheets he cannot see.
How can I alter the code below to only display comments for cells he can see?
Note: I did not create this code, merely adopted it as it almost suits my needs.
Sub ShowCommentsAllSheets()
Application.ScreenUpdating = False
Dim commrange As Range
Dim mycell As Range
Dim ws As Worksheet
Dim newwks As Worksheet
Dim i As Long
Set newwks = Worksheets.Add
newwks.Range("A1:E1").Value = _
Array("Sheet", "Address", "Name", "Value", "Comment")
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If commrange Is Nothing Then
Else
i = newwks.Cells(Rows.Count, 1).End(xlUp).Row
For Each mycell In commrange
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = ws.Name
.Cells(i, 2).Value = mycell.Address
.Cells(i, 3).Value = mycell.Name.Name
.Cells(i, 4).Value = mycell.Value
.Cells(i, 5).Value = mycell.Comment.Text
End With
Next mycell
End If
Set commrange = Nothing
Next ws
newwks.Cells.WrapText = False
newwks.Columns("E:E").Replace What:=Chr(10), _
Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Application.ScreenUpdating = True
End Sub
I believe I need to add this code to fix the problem:
Comments = 1
For Each MyComments In ActiveSheet.Comments
If MyComments.Visible = True Then
Comments = 0
End If
Next
If Comments = 1 Then
Application.DisplayCommentIndicator = xlCommentAndIndicator
Else
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
End If
However, I am struggling to fit this into the code. How should I proceed?
Code amended to cover visible sheets and then cells which are not hidden.
Sub ShowCommentsAllSheets()
Application.ScreenUpdating = False
Dim commrange As Range
Dim mycell As Range
Dim ws As Worksheet
Dim newwks As Worksheet
Dim i As Long
Set newwks = Worksheets.Add
newwks.Range("A1:E1").Value = _
Array("Sheet", "Address", "Name", "Value", "Comment")
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
On Error Resume Next
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If Not commrange Is Nothing Then
i = newwks.Cells(Rows.Count, 1).End(xlUp).Row
For Each mycell In commrange
If Not (mycell.EntireRow.Hidden Or mycell.EntireColumn.Hidden) Then
With newwks
i = i + 1
On Error Resume Next
.Cells(i, 1).Value = ws.Name
.Cells(i, 2).Value = mycell.Address
.Cells(i, 3).Value = mycell.Name.Name
.Cells(i, 4).Value = mycell.Value
.Cells(i, 5).Value = mycell.Comment.Text
End With
End If
Next mycell
End If
Set commrange = Nothing
End If
Next ws
newwks.Cells.WrapText = False
newwks.Columns("E:E").Replace What:=Chr(10), _
Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Application.ScreenUpdating = True
End Sub

How to apply another filter, if one filter is already applied in VBA

I was trying to write a code. I 've applied a filter and then I need to apply one more filter after few lines. But the second filter is not getting applied. Here is my code-
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Sub occ_const_ashish()
Dim wb As Worksheet
Dim bldscrng As Range
Dim wb1 As String
Dim i As String, j As String
Dim arr() As Variant
Dim arrTemp() As Variant
Set wb = Sheets(ActiveSheet.Name)
wb1 = ActiveSheet.Name
wb.Activate
LC = Sheets(wb1).Cells(1, Columns.Count).End(xlToLeft).Column
' Sets the search range as A1 to the last column with a header on the Run sheet
Set sRange = Sheets(wb1).Range("A1", Cells(1, LC))
' With the search range
With sRange
' Set Rng as the cell where "Country" is found
Set cntryrng = .Find(What:="CNTRYCODE", After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not cntryrng Is Nothing Then
' Define LastRow as the last row of data under the Due Date header
LR = Sheets(wb1).Cells(Rows.Count, cntryrng.Column).End(xlUp).Row
' Copy from the Due Date header down to the last row of that column and paste to A1 of Paste Report Here sheet
'Set rngSourceRange1 = Sheets(wb1).Range(cntryrng(2), Cells(LR, cntryrng.Column))
Set rngSourceRange1 = Sheets(wb1).Range(cntryrng(2), Cells(LR, cntryrng.Column))
For Each cell In rngSourceRange1
i = cell.Value
rw = cell.Row
'MsgBox i
With ThisWorkbook.Sheets("Construction")
arr = Application.Transpose(.Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value2)
End With
'arr1 = Application.Transpose(Sheets(wb1).Range(Sheets(wb1).Cells(2, 5), Sheets(wb1).Cells(Sheets(wb1).Cells(Sheets(wb1).Rows.Count, 5).End(xlUp).Row, 5)).Value2)
If IsInArray(i, arr) Then
'arrayTemp = Filter(arr1, i)
'MsgBox Join(arrayTemp, ",")
With ThisWorkbook.Sheets("Construction")
.AutoFilterMode = False
.Range("A1:E1").AutoFilter
.Range("A1:E1").AutoFilter Field:=1, Criteria1:=i
End With
With sRange
' Set Rng as the cell where "Country" is found
Set bldscrng = .Find(What:="BLDGSCHEME", After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
col1 = bldscrng.Cells(1, 1).Column
j = Cells(rw, col1).Value
If j = "" Then
Cells(rw, LC + 1).Value = "BLDSCHEME is BLANK"
'MsgBox "bldscheme is blank"
Else
'MsgBox j
With ThisWorkbook.Sheets("Construction")
arr1 = Application.Transpose(.Range(.Cells(2, 3), .Cells(.Cells(.Rows.Count, 3).End(xlUp).Row, 3)).Value2)
End With
If IsInArray(j, arr1) Then
'MsgBox "scheme found"
With ThisWorkbook.Sheets("Construction")
If ActiveSheet.AutoFilterMode = False Then Range("A1:E1").AutoFilter
.Range("A1:E1").AutoFilter
.Range("A1:E1").AutoFilter Field:=1, Criteria1:=i
.Range("A1:E1").AutoFilter Field:=3, Criteria1:=j
End With
Else
'MsgBox "scheme not found"
Cells(rw, LC + 1).Value = "BLDSCHEME is INVALID"
End If
End If
End With
Else
MsgBox "Country not found"
End If
Next cell
End If
End With
End Sub
The problem is here:
If ActiveSheet.AutoFilterMode = False Then ...
Here you check if the AutoFilterMode is false while you have applied a filter in the previous lines. So it goes to the Else part and shows: MsgBox "scheme not found".
Modify this part of the code as below to comprehend what I mean:
With ThisWorkbook.Sheets("Construction")
.AutoFilterMode = False
Debug.Print .AutoFilterMode 'before applying autofilter
.Range("A1:E1").AutoFilter
Debug.Print .AutoFilterMode 'after applying autofilter
.Range("A1:E1").AutoFilter Field:=1, Criteria1:=i
End With
Also, when you want to use this much if-statements try to make the indentation clear and have some comments (maybe numbering) to make your code legible. Moreover, you can consider using Select Case.

Modify macro for column search

I have a macro that until now was used just to search one cell from column F but now I must search for all the cell in column F. If value from F is found in range N:AN, offset(f,0,1) must have the cell value (found row , column AI).
Sub find()
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("f48").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("n:an")
Set Rng = .find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Sheets("Sheet1").Range("f48").Offset(0, 1).Value = Rng.Offset(0, 21).Value
Else
Sheets("Sheet1").Range("f48").Offset(0, 1).Value = "Nothing found"
End If
End With
End If
End Sub
Perhaps this, if I understand correctly (it does assume the value in F will only be found once at most).
Sub find()
Dim Rng As Range
Dim r As Range
With Sheets("Sheet1")
For Each r In .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
If Trim(r) <> vbNullString Then
With .Range("n:an")
Set Rng = .find(What:=r.Value, _
LookAt:=xlWhole, _
MatchCase:=False)
If Not Rng Is Nothing Then
r.Offset(0, 1).Value = .Cells(Rng.Row, "AI").Value
'Else
' Sheets("Sheet1").Range("f48").Offset(0, 1).Value = "Nothing found"
End If
End With
End If
Next r
End With
End Sub
See if this is helpful. Its a bit of a change but I think it may be cleaner :)
Of course you need to adjust it for your offset criteria once you "find" a match in the N:NA range
Sub Dougsloop()
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim aRR As Variant
Set wsO = ThisWorkbook.Sheets("Sheet1")
aRR = wsO.UsedRange.Columns("N:NA")
Set rRng = ThisWorkbook.Sheets("Sheet1").Range("F1:F500")
For Each rCell In rRng.Cells
If Trim(rCell.Value) <> vbNullString Then
thisValue = rCell.Value
If IsError(Application.Match(aRR, thisValue, 0)) = True Then
'Generic Eror Handling
ElseIf IsError(Application.Match(aRR, thisValue, 0)) = False Then
'Stuff you do when you find the match
rCell.Offset(0, 1).Value = "found it"
End If
End If
Next rCell
End Sub

Search for string in each open worksheet

I would like to use values from each instance of the string FindString to populate textboxes in UserForm1.
I am getting the unique WorkSheet per textbox. But the rest of the values are from the sheet active when I run the module.
This mean the string Rng isn't looping through the WorkSheets, but staying with the initial WorkSheet. How can I remedy this?
Public Sub FindString()
Dim FindString As Variant
Dim Rng As Range
Dim SheetName As String
Dim ws As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
SheetName = ActiveSheet.Name
FindString = Cells(ActiveCell.Row, 1).Value
FindString = InputBox("Enter the case number to search for:", "Case ID", FindString)
If FindString = "" Then Exit Sub
If FindString = False Then Exit Sub
i = 1
For Each ws In Worksheets
If ws.Name Like "Lang*" Then
With ws
If Trim(FindString) <> "" Then
With Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
UserForm1.Controls("TextBox" & i) = ws.Name & vbTab & _
Rng.Offset(0, 2).Value & vbTab & _
Rng.Offset(0, 5).Value & vbTab & _
Rng.Offset(0, 6).Value & vbTab & _
Rng.Offset(0, 7).Value & vbTab & _
Rng.Offset(0, 8).Value
i = i + 1
Else: GoTo NotFound
End If
End With
End If
End With
End If
Next ws
Sheets(SheetName).Activate
Application.ScreenUpdating = True
UserForm1.Show
Exit Sub
NotFound:
Sheets(SheetName).Activate
Application.ScreenUpdating = True
MsgBox "Case ID not found"
Exit Sub
End Sub
Got it!
Just needed to add
ws.Activate
after
If ws.Name Like "Lang*" Then