Sub find_match_engine()
Dim mykeyword As String
Dim foundRange As Range
Dim LastRow As Long, ws As Worksheet
Dim Row As Variant
Dim Name As String
mykeyword = ThisWorkbook.Sheets("Search").Range("L2").Value
ThisWorkbook.Sheets("Search").Range("A3:K365").ClearContents
Application.ScreenUpdating = False
Set foundRange = ThisWorkbook.Sheets("Denyo").Range("A3:A60").Find(mykeyword & "*")
If foundRange Is Nothing Then
GoTo Line1
Exit Sub
Else
'While foundRange <> ""
Set ws = ThisWorkbook.Sheets("Search")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = "Denyo"
ws.Range("A" & LastRow).Offset(0, 1).Value = foundRange.Value
ws.Range("A" & LastRow).Offset(0, 2).Value = foundRange.Offset(0, 1).Value
ws.Range("A" & LastRow).Offset(0, 3).Value = foundRange.Offset(0, 2).Value
ws.Range("A" & LastRow).Offset(0, 4).Value = foundRange.Offset(0, 3).Value
ws.Range("A" & LastRow).Offset(0, 5).Value = foundRange.Offset(0, 4).Value
ws.Range("A" & LastRow).Offset(0, 6).Value = foundRange.Offset(0, 5).Value
ws.Range("A" & LastRow).Offset(0, 7).Value = foundRange.Offset(0, 6).Value
ws.Range("A" & LastRow).Offset(0, 8).Value = foundRange.Offset(0, 7).Value
ws.Range("A" & LastRow).Offset(0, 9).Value = foundRange.Offset(0, 8).Value
ws.Range("A" & LastRow).Offset(0, 10).Value = foundRange.Offset(0, 9).Value
'Wend
End If
Line1:
Set foundRange = ThisWorkbook.Sheets("Hitachi").Range("A3:A358").Find(mykeyword & "*")
If foundRange Is Nothing Then
GoTo Line2
'MsgBox "No Engine Model Files Found", vbInformation, "NO FILE HISTORY"
Exit Sub
Else
'While Name <> ""
Set ws = ThisWorkbook.Sheets("Search")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = "Hitachi"
ws.Range("A" & LastRow).Offset(0, 1).Value = foundRange.Value
ws.Range("A" & LastRow).Offset(0, 2).Value = foundRange.Offset(0, 1).Value
ws.Range("A" & LastRow).Offset(0, 3).Value = foundRange.Offset(0, 2).Value
ws.Range("A" & LastRow).Offset(0, 4).Value = foundRange.Offset(0, 3).Value
ws.Range("A" & LastRow).Offset(0, 5).Value = foundRange.Offset(0, 4).Value
ws.Range("A" & LastRow).Offset(0, 6).Value = foundRange.Offset(0, 5).Value
ws.Range("A" & LastRow).Offset(0, 7).Value = foundRange.Offset(0, 6).Value
ws.Range("A" & LastRow).Offset(0, 8).Value = foundRange.Offset(0, 7).Value
ws.Range("A" & LastRow).Offset(0, 9).Value = foundRange.Offset(0, 8).Value
ws.Range("A" & LastRow).Offset(0, 10).Value = foundRange.Offset(0, 9).Value
'Wend
End If
Line2:
Related
I currently am using a userform I created to log data into a spreadsheet. During data validation, I notice that when I key in dates in the DD/MM/YYYY format in the userform, some rows swap the DD/MM to MM/DD, which causes confusion downstream.
I adjusted the data type for the entire column, but the userform code seems act differently for the particular row. Is this a bug or am I overlooking a line of code somewhere?
Here are the images of the userform and the data in the spreadsheet, as well as the code for the information transfer segment.
Data from spreadsheet
Userform Date segment
Code for transfer information:
'Transfer information
Cells(emptyRow, 1).Value = p
Cells(emptyRow, 3).Value = hour.Value & ":" & minute.Value & " " & ampm.Value
Cells(emptyRow, 4).Value = PTID.Value
Cells(emptyRow, 2).Value = cmbdate.Value & "/" & cmbmonth.Value & "/" & cmbyear.Value
Cells(emptyRow, 5).Value = UNIT.Value
Cells(emptyRow, 6).Value = PCBOX.Value
Cells(emptyRow, 7).Value = WASTE.Value
Cells(emptyRow, 8).Value = REPORTED.Value
Cells(emptyRow, 9).Value = DETBOX.Value
Cells(emptyRow, 10).Value = FOLBOX.Value
Cells(emptyRow, 11).Value = SUMBOX.Value
Cells(emptyRow, 12).Value = CAPBOX.Value
Cells(emptyRow, 13).Value = EHOR.Value
Cells(emptyRow, 14).Value = TECHS.Value & "," & TECHS2.Value & "," & TECHS3.Value & "," & TECHS4.Value
Cells(emptyRow, 15).Value = ERRORBOX.Value
Cells(emptyRow, 16).Value = PREVBOX.Value
Cells(emptyRow, 17).Value = SOP.Value
Cells(emptyRow, 18).Value = AUDIFILE.Value
Cells(emptyRow, 19).Value = INTERFILE.Value
Cells(emptyRow, 20).Value = cmbdate2.Value & "/" & cmbmonth2.Value & "/" & cmbyear2.Value
Cells(emptyRow, 23).Value = Phase.Value
Cells(emptyRow, 24).Value = QIM.Value
MsgBox "Please check your entry in the sheet", , "Entry Complete"
MsgBox "Your entry serial number is " & p
SN.Text = p
VNCFORM.Hide
Code for recall information (to same userform, when a serial number for the entry is entered into the userform)
Private Sub SN_AfterUpdate()
'TO RETRIEVE S/N DATA TO THE USERFORM'
Dim x As Range
Dim y As Long
Set WS = Worksheets("Data")
y = Application.WorksheetFunction.Match(CLng(Me.SN.Value), WS.Range("A:A"), 0)
'POSSIBLE PROBLEM AREA'
Me.cmbdate.Value = Left(WS.Range("B" & y).Value, 2)
Me.cmbmonth.Value = Mid(WS.Range("B" & y).Value, 4, 2)
Me.cmbyear.Value = Right(WS.Range("B" & y).Value, 4)
Me.hour.Value = CStr(Left(WS.Range("C" & y).Value, 2))
Me.minute.Value = CStr(Mid(WS.Range("C" & y).Value, 4, 2))
Me.ampm.Value = CStr(Right(WS.Range("C" & y).Value, 2))
Me.PTID.Value = WS.Range("D" & y).Value
Me.UNIT.Value = WS.Range("E" & y).Value
Me.PCBOX.Value = WS.Range("F" & y).Value
Me.WASTE.Value = WS.Range("G" & y).Value
Me.REPORTED.Value = WS.Range("H" & y).Value
Me.DETBOX.Value = WS.Range("I" & y).Value
Me.FOLBOX.Value = WS.Range("J" & y).Value
Me.SUMBOX.Value = WS.Range("K" & y).Value
Me.CAPBOX.Value = WS.Range("L" & y).Value
Me.EHOR.Value = WS.Range("M" & y).Value
'Techs involved in case transcribed back to userform
Dim MYARRAY() As String, MYSTRING As String
MYSTRING = WS.Range("N" & y).Value
MYARRAY = Split(MYSTRING, ",")
For N = 0 To UBound(MYARRAY)
Me.TECHS.Value = MYARRAY(0)
Me.TECHS2.Value = MYARRAY(1)
Me.TECHS3.Value = MYARRAY(2)
Me.TECHS4.Value = MYARRAY(3)
Next N
Me.ERRORBOX.Value = WS.Range("O" & y).Value
Me.PREVBOX.Value = WS.Range("P" & y).Value
Me.SOP.Value = WS.Range("Q" & y).Value
Me.AUDIFILE.Value = WS.Range("R" & y).Value
Me.INTERFILE.Value = WS.Range("S" & y).Value
Me.cmbdate2.Value = Left(WS.Range("T" & y).Value, 2)
Me.cmbmonth2.Value = Mid(WS.Range("T" & y).Value, 4, 2)
Me.cmbyear2.Value = Right(WS.Range("T" & y).Value, 4)
Me.Phase.Value = WS.Range("W" & y).Value
Me.QIM.Value = WS.Range("X" & y).Value
End Sub
The problem seems to occur when I recall data back into the userform where the month value and the date values get swapped for some reason.
Is there a property of code I am overlooking? Or could I improve the code somehow; I think the error comes from the recall segment (see: 'POSSIBLE PROBLEM AREA')
I would make sure when writing/reading dates you're being more explicit:
'write date to sheet
Cells(emptyRow, 2).Value = DateSerial(CLng(cmbyear.Value), _
CLng(cmbmonth.Value), _
CLng(cmbdate.Value))
'read date from sheet
Dim dt As Date
dt = WS.Range("B" & y).Value
Me.cmbdate.Value = Day(dt)
Me.cmbmonth.Value = Month(dt)
Me.cmbyear.Value = Year(dt)
Also likely need some code to check there's an entry before trying to write/read it.
The table contains column G = City, H = Department and J = Date. In the columns J Date some values are missing. I want to output these rows on a new worksheet with (column A) the rownumber, (column B) the city and (column) the departement.
The code I have looks like this but in the output all rows with a value in J = Date and the output is in the columns "G, H, J". I tried to change the columns in the code but I failed.
Sub missing()
Dim ws, wsOut As Worksheet
Set ws = ActiveWorkbook.Sheets("Table1")
Set wsOut = ActiveWorkbook.Sheets("output")
lastRow = ws.Range("G" & Rows.Count).End(xlUp).Row
lastRowOut = wsOut.Range("G" & Rows.Count).End(xlUp).Row + 1
For i = 1 To lastRow
If (ws.Cells(i, 10).Value = "") _
And _
((ws.Cells(i, 7).Value = "Peking") Or _
(ws.Cells(i, 7).Value = "Tokio") Or _
(ws.Cells(i, 7).Value = "London") Or _
(ws.Cells(i, 7).Value = "Rom") Or _
(ws.Cells(i, 7).Value = "Lissabon") Or _
(ws.Cells(i, 7).Value = "Panama") Or _
(ws.Cells(i, 7).Value = "Budapest") Or _
(ws.Cells(i, 7).Value = "Prag") Or _
(ws.Cells(i, 7).Value = "Dublin") Or _
(ws.Cells(i, 7).Value = "Luxemburg")) _
And _
((ws.Cells(i, 8).Value = "A") Or _
(ws.Cells(i, 8).Value = "B") Or _
(ws.Cells(i, 8).Value = "C") Or _
(ws.Cells(i, 8).Value = "D") Or _
(ws.Cells(i, 8).Value = "E") Or _
(ws.Cells(i, 8).Value = "F") Or _
(ws.Cells(i, 8).Value = "G") Or _
(ws.Cells(i, 8).Value = "H") Or _
(ws.Cells(i, 8).Value = "I") Or _
(ws.Cells(i, 8).Value = "J")) _
Then
wsOut.Range("B" & lastRowOut & ":C" & lastRowOut).Value = ws.Range("G" & i & ":H" & i).Value
wsOut.Range("A" & lastRowOut).Value = i
lastRowOut = lastRowOut + 1
End If
Next i
End Sub
while i was writing this others have answered and honestly I like there solution but can also be done like this:
Sub missing()
Dim ws, wsOut As Worksheet
Set ws = ActiveWorkbook.Sheets("table")
Set wsOut = ActiveWorkbook.Sheets("output")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastRowOut = wsOut.Range("A" & Rows.Count).End(xlUp).Row + 1
For i = 2 To lastRow
If ws.Cells(i, 3).Value = "" Then
wsOut.Range("A" & lastRowOut & ":B" & lastRowOut).Value = ws.Range("A" & i & ":B" & i).Value
wsOut.Range("C" & lastRowOut).Value = i
lastRowOut = lastRowOut + 1
End If
Next i
End Sub
assuming table is in worksheet "table" and output is wanted in a worksheet called "output" [note output has to have a value somewhere in column A before the code is run or an error will be thrown]
Also the code you show does not appear to be trying to answer the question you've asked, it may just be that you took a wrong turn but it is quite different, let us know if we've all missed the point!
Click on cell "A1", press Ctrl+G and choose "Special", "current region" (that should select the whole array). Again press Ctrl+G and choose "Special", this type choose "Blanks".
In the address bar, type "No Date".
Press Ctrl+ENTER (don't forget the control-button).
You can record this into a macro.
Have fun :-)
Oh, by the way, this is wrong:
If Cells(i, 1).Value = "Peking" Or "Tokio" Or "London" Or ...
It should be something like:
If Cells(i, 1).Value = "Peking" Or_
Cells(i, 1).Value = "Tokio" Or_
...
(The underscore after "Or" is just to explain VBA that this should be treated as one single line.)
Not sure i'm 100% with you, but
Dim r as range
dim c as range
dim a() as variant
dim i as long
set r=range("c2:c22").specialcells(xlcelltypeblanks)
redim a(1 to r.cells.count,1)
i=1
for each c in r.cells
a(i,0) = cells(c.row,1)
a(i,1)=cells(c.row,2)
i=i+1
next c
' Output, to j1 on the same sheet.
cells(1,10).resize(ubound(a),2).value=a
Do While Cells(i, 1).Value <> ""
....
End If
i = i + 1
Loop
End Sub
Right. It works fine with numbers and stop perfectly. But With Text. It does not stop.
Ideally I want to stop at the last row of my content rather than my last row in Excel. I manage to make it work fine with numbers, but I cannot fix it with Text.
Any help would be great as I am a beginner in VBA.
Sub checkRoutine()
Dim i As Integer
Dim LastRow As Long
i = 1
Do While Cells(i, 1).Value <> ""
If IsNumeric(Cells(i, 1).Value) Then Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
If Not IsNumeric(Cells(i, 1).Value) Then
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
ActiveSheet.Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
i = i + 1
Loop
End Sub
As suggested by so many people, you need to change to use a For loop:
Sub checkRoutine()
Dim i As Long
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).row
For i = 1 To LastRow
If IsNumeric(Cells(i, 1).Value) Then
Cells(i, 2).Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
Else
LastRow = Range("A" & Rows.Count).End(xlUp).row + 1
Cells(LastRow, "A").Value = Cells(i, 1).Value & " " & Cells(7, 5).Value
End If
Next
End Sub
I'm still only learning VBA, but I'm having an issue with the below, where data being entered by the userform is overwriting existing rows.
Able to help?
' Write data to worksheet
rowcount = Worksheets("Register").Range("A4").CurrentRegion.Rows.Count
With Worksheets("Register").Range("A4")
.Offset(rowcount, 0).Value = Me.txtID.Value
.Offset(rowcount, 1).Value = Me.txtRecDate
.Offset(rowcount, 2).Value = Me.txtPerson.Value
.Offset(rowcount, 3).Value = Me.txtEntity.Value
.Offset(rowcount, 4).Value = Me.cboCorresType.Value
.Offset(rowcount, 5).Value = Me.cboInTray.Value
.Offset(rowcount, 6).Value = "FALSE"
.Offset(rowcount, 50).Value = Format(Now, "dd/mm/yyyy hh:mm:ss")
.Offset(rowcount, 51).Value = Environ("Username")
End With
After some more research on the interweb...
' Write data to worksheet
Set ws = Sheets("Register")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & LastRow).Value = Me.txtID.Value
ws.Range("B" & LastRow).Value = Me.txtRecDate
ws.Range("C" & LastRow).Value = Me.txtPerson.Value
ws.Range("D" & LastRow).Value = Me.txtEntity.Value
ws.Range("E" & LastRow).Value = Me.cboCorresType.Value
ws.Range("F" & LastRow).Value = Me.cboInTray.Value
ws.Range("G" & LastRow).Value = "FALSE"
ws.Range("AY" & LastRow).Value = Format(Now, "DD/MM/YYYY hh:mm:ss")
ws.Range("AZ" & LastRow).Value = Environ("Username")
Me again... I've got some code that copies cells from a certain column (from sheet "Convertor") and pastes it into a different column (sheet "Unallocated"). These values (IDs) are then used as a reference point to move the rest of the cells for each row (record) into the correct position I need it in.
However I can't get the code to continuously copy the IDs into a blank row so that they don't overwrite the previous set. I think it's something to do with the line Master.Cells(rowB, colB) = yourData but I can't figure it out. I tried changing the rowB to be the same xlUp to find the last unused cell in the column (as with lastA = Slave.Cells(Rows.Count, colA).End(xlUp).Row), but I couldn't get it to work. Any ideas?
Current code:
Private Sub CommandButton21_Click()
Dim colA As Integer, colB As Integer
Dim rowA As Integer, rowB As Integer
Dim Master As Worksheet, Slave As Worksheet 'declare both
Application.ScreenUpdating = False
Set Master = ThisWorkbook.Worksheets("Unallocated")
Set Slave = ThisWorkbook.Worksheets("Convertor")
colA = 17
colB = 29
rowA = 1
rowB = 1
lastA = Slave.Cells(Rows.Count, colA).End(xlUp).Row 'This finds the last row of the data of the column FROM which i'm copying
For x = rowA To lastA 'Loops through all the rows of A
yourData = Cells(x, colA)
Master.Cells(rowB, colB) = yourData
rowB = rowB + 1 'Increments the current line of destination workbook
Next x 'Skips to next row
For j = 1 To 5000 '(the master sheet)
For i = 1 To 5000 '(the slave sheet) 'for first 1000 cells
If Trim(Master.Cells(j, 29).Value2) = vbNullString Then Exit For 'if ID cell is blank exit
If Master.Cells(j, 29).Value = Slave.Cells(i, 17).Value Then
If IsEmpty(Slave.Cells(i, 3)) Then Exit Sub
Master.Cells(j, 2).Value = Slave.Cells(i, 3).Value 'Move all other data based on the ID
Master.Cells(j, 8).Value = Slave.Cells(i, 4).Value
Master.Cells(j, 9).Value = Slave.Cells(i, 5).Value
Master.Cells(j, 10).Value = Slave.Cells(i, 6).Value
Master.Cells(j, 11).Value = Slave.Cells(i, 7).Value
Master.Cells(j, 12).Value = Slave.Cells(i, 8).Value
Master.Cells(j, 13).Value = Slave.Cells(i, 9).Value
Master.Cells(j, 4).Value = Slave.Cells(i, 10).Value
Master.Cells(j, 23).Value = Slave.Cells(i, 11).Value
Master.Cells(j, 24).Value = Slave.Cells(i, 12).Value
Master.Cells(j, 25).Value = Slave.Cells(i, 13).Value
Master.Cells(j, 26).Value = Slave.Cells(i, 14).Value
Master.Cells(j, 27).Value = Slave.Cells(i, 15).Value
Master.Cells(j, 28).Value = Slave.Cells(i, 16).Value
If Not IsEmpty(Slave.Cells(i, 3)) Then _
Slave.Cells(i, 3).EntireRow.Delete 'deletes row after it has been copied
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Let's start with a simple loop copying data for each row. Then you can add in your checks.
You can use worksheet.range to write to cells (column row) such as ("A4") or ("A" & counter).
Private Sub CommandButton21_Click()
Dim ws As Excel.Worksheet
Dim wsMaster As Excel.Worksheet
Dim strValue As String
Set ws = ActiveWorkbook.Sheets("Convertor")
Set wsMaster = ActiveWorkbook.Sheets("Unallocated")
'Count of row to read from
Dim lRow As Long
lRow = 1
'Count of row to write to
Dim jRow As Long
jRow = 1
ws.Activate
'Loop through and copy what is in the rows
Do While lRow <= ws.UsedRange.Rows.count
wsMaster.Range("AC" & jRow).Value = ws.Range("Q" & lRow).Value
wsMaster.Range("B" & jRow).Value = ws.Range("C" & lRow).Value
wsMaster.Range("H" & jRow).Value = ws.Range("D" & lRow).Value
wsMaster.Range("I" & jRow).Value = ws.Range("E" & lRow).Value
wsMaster.Range("J" & jRow).Value = ws.Range("F" & lRow).Value
wsMaster.Range("K" & jRow).Value = ws.Range("G" & lRow).Value
wsMaster.Range("L" & jRow).Value = ws.Range("H" & lRow).Value
wsMaster.Range("M" & jRow).Value = ws.Range("I" & lRow).Value
wsMaster.Range("D" & jRow).Value = ws.Range("J" & lRow).Value
wsMaster.Range("W" & jRow).Value = ws.Range("K" & lRow).Value
wsMaster.Range("X" & jRow).Value = ws.Range("L" & lRow).Value
wsMaster.Range("Y" & jRow).Value = ws.Range("M" & lRow).Value
wsMaster.Range("Z" & jRow).Value = ws.Range("N" & lRow).Value
wsMaster.Range("AA" & jRow).Value = ws.Range("O" & lRow).Value
wsMaster.Range("AB" & jRow).Value = ws.Range("P" & lRow).Value
ws.Rows(lRow).EntireRow.Delete
'Increment counters for both sheets. We can actually use just one counter, but if there is ever a condition that will cause us to not copy a row, then we will need two counters.
jRow = jRow + 1
'lRow = lRow + 1 'This is commented out because we are deleting rows after we copy them.
Loop
End Sub
If you really need to delete the rows after they are copied then we will have to not increment the lRow value.
.Cells is Limiting your approach.
Consider Change to Using Range("A1:C3000") notation it's more powerful.
Range.Select
Range.Paste (to new High mark for UsedRows.Count at destination)
Also unless you have exactly 5000 rows, it's not that accurate,
experiment with
ActiveSheet.UsedRange.Rows.Count