The VBA code below represents a copy-paste function, filtered by two conditions. The code works and gets the job done, but the problem is the time for it to generate the results - Is there anyone here who knows a more efficient way to write the same code?
Any suggestions are highly appreciated
Private Sub CommandButton3_Click()
Dim c As Range, i As Integer, j As Integer
Range("N6:R50").ClearContents
i = 0
For Each c In Range("B2:B50")
If c = Range("O3").Value And Month(c.Offset(0, -1).Value) = Range("P1").Value Then
Cells(6 + i, 14) = Cells(c.Row, c.Column - 1)
Cells(6 + i, 15) = Cells(c.Row, c.Column + 1)
Cells(6 + i, 16) = Cells(c.Row, c.Column + 2)
Cells(6 + i, 17) = Cells(c.Row, c.Column + 3)
Cells(6 + i, 18) = Cells(c.Row, c.Column + 4)
End If
i = i + 1
Next c
For j = 50 To 6 Step -1
If Cells(j, 15) = "" Then
Range("N" & j, "R" & j).Delete Shift:=xlUp
End If
Next j
End Sub
Try this code (you might change ranges [6] depending on your headers):
Private Sub CommandButton3_Click()
Dim rng As Range
Dim LR As Long
Application.ScreenUpadting = False
LR = Range("N6").CurrentRegion.Rows.Count + 5
Range("N6:R" & LR).ClearContents
LR = Range("A6").CurrentRegion.Rows.Count + 5
Range("A6").CurrentRegion.AutoFilter 1, Range("P1")
Range("A6").CurrentRegion.AutoFilter 2, Range("O3")
If Range("A6").CurrentRegion.SpecialCells(xlCellTypeVisible).Areas.Count > 1 Then
Range("N6:N" & LR).SpecialCells(xlCellTypeVisible).Value = Range("B7:B" & LR).SpecialCells(xlCellTypeVisible).Value
Range("O6:R" & LR).SpecialCells(xlCellTypeVisible).Value = Range("C7:F" & LR).SpecialCells(xlCellTypeVisible).Value
Range("A6").CurrentRegion.AutoFilter
Set rng = Range("N7:R" & LR).SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
End If
End Sub
I am having a sheet having seven cloumns. First six columns having either true or false and in last column I have to mention the heading of false cases in one statement. Below is the excel.
Excel sheet
I have tried if else statement but there are too many possibilities. Since I am new to VBA i don't know any shortcut to that.Any suggestions?.... Thanks
Try this simple vba code,
Sub TEXTJOIN()
Dim i As Long, str As String, k As Long, j As Long
str = ""
j = 0
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A" & i & ":F" & i), True) = 6 Then
Cells(i, 7) = "No Discrepancy Found"
Else
For k = 1 To 6
If Cells(i, k) = False Then
str = str & Cells(1, k) & ","
j = j + 1
End If
Next k
str = Left(str, Len(str) - 1) & " mismatch found"
Cells(i, 7) = Application.WorksheetFunction.Substitute(str, ",", " and ", j - 1)
str = ""
j = 0
End If
Next i
End Sub
Here's simple code which you should try:
Sub FindDiscrepancies()
Dim lastRow, i, j As Long
Dim discrepancies As String: discrepancies = ""
'find number of last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
For j = 1 To 6
If LCase(Cells(i, j).Value) = "false" Then
discrepancies = discrepancies & Cells(1, j).Value & ", "
End If
Next j
If discrepancies = "" Then
Cells(i, 7).Value = "No discrepancies found"
Else
Cells(i, 7).Value = "Mismatch found in " & discrepancies
End If
discrepancies = ""
Next i
End Sub
I would like to be able to copy around 30k rows (to be exact, just some elements of the rows) from sheet A to sheet B, starting the destination from row nr 36155. Sometimes, we copy the row more than once, depending on the number in the G column. This is the macro I've written:
Sub copy()
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
Dim k As Long, k1 As Long, i As Integer
k = 36155
k1 = 30000
For i = 1 To k1
For j = 1 To Sheets("A").Range("G" & i + 2).Value
Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
Sheets("B").Range("B" & k).Value = Sheets("A").Range("B" & i + 2).Value
Sheets("B").Range("C" & k).Value = j
Sheets("B").Range("D" & k).Value = Sheets("A").Range("C" & i + 2).Value
Sheets("B").Range("E" & k).Value = Sheets("A").Range("D" & i + 2).Value
Sheets("B").Range("F" & k).Value = Sheets("A").Range("E" & i + 2).Value
Sheets("B").Range("G" & k).Value = Sheets("A").Range("F" & i + 2).Value
Sheets("B").Range("H" & k).Value = Sheets("A").Range("I" & i + 2).Value + (j - 1) * Sheets("A").Range("H" & i + 2).Value
Sheets("B").Range("I" & k).Value = Sheets("A").Range("J" & i + 2).Value
k = k + 1
Next j
Next i
Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Unfortunately, this macro takes a lot of time to run (around 10 minutes). I have a feeling that, there may be a better way to do that.. Do you have any ideas, how can we enchance the macro?
Try this using variant arrays: could be even faster if you can use a B array containing more than 1 row. This version takes 17 seconds on my PC.
Sub Copy2()
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
'
Dim k As Long, k1 As Long, i As Long, j As Long
Dim varAdata As Variant
Dim varBdata() As Variant
'
Dim dT As Double
'
dT = Now()
'
k = 36155
k1 = 30000
'
' get sheet A data into variant array
'
varAdata = Worksheets("A").Range("A1:J1").Resize(k1 + 2).Value2
'
For i = 1 To k1
'For j = 1 To Sheets("A").Range("G" & i + 2).Value
For j = 1 To varAdata(i + 2, 7)
'
' create empty row of data for sheet B and fill from variant array of A data
'
ReDim varBdata(1 to 1,1 to 9) As Variant
'Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
varBdata(1, 1) = varAdata(i + 2, 1)
varBdata(1, 2) = varAdata(i + 2, 2)
varBdata(1, 3) = j
varBdata(1, 4) = varAdata(i + 2, 3)
varBdata(1, 5) = varAdata(i + 2, 4)
varBdata(1, 6) = varAdata(i + 2, 5)
varBdata(1, 7) = varAdata(i + 2, 6)
varBdata(1, 8) = varAdata(i + 2, 9) + (j - 1) * varAdata(i + 2, 8)
varBdata(1, 9) = varAdata(i + 2, 10)
'
' write to sheet B
'
Sheets("B").Range("A1:I1").Offset(k - 1).Value2 = varBdata
k = k + 1
Next j
Next i
'
Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox (Now() - dT)
End Sub
I would suggest you read your data into a recordset as shown here, then loop the recordset.
Try the following (untested).
Sub copy()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculate
.Calculation = xlCalculationManual
End With
Dim k As Long, i As Integer
k = 36155
' read data into a recordset
Dim rst As Object
Set rst = GetRecordset(ThisWorkbook.Sheets("A").UsedRange) 'feel free to hard-code your range here
With rst
While Not .EOF
For j = 1 To !FieldG
' !FieldG accesses the Datafield with the header "FieldG". Change this to the header you actually got in Column G, like "!MyColumnG" or ![columnG with blanks]
Sheets("B").Cells(k, 1).Value = !FieldA
' ... your code
k = k + 1
Next j
.movenext
Wend
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Also add the following Function into your VBA Module.
Function GetRecordset(rng As Range) As Object
'Recordset ohne Connection:
'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/
Dim xlXML As Object
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
Set xlXML = CreateObject("MSXML2.DOMDocument")
xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML)
rst.Open xlXML
Set GetRecordset = rst
End Function
Note:
- using a recordset gives you additional options like filtering data
- with a recordset, your not dependent on the column-order of your input-data, meaning you don't have to adjust your macro if you decide to add another column to sheet A (as long as you keep the headers the same)
Hope this helps.
i need some help with search function with this, how can i convert this that userform will search other sheet of my workbook
name of other sheet is "DataSource"
im planning to separate the data into another sheet of workbook then define a name and i will make it as offset so inshort whenever i put another data it will be able to search with the use of my search userform
This is my code
Sub GetData()
Dim id As Integer, i As Integer, j As Integer, flag As Boolean
If IsNumeric(UserForm1.TextBox1.Value) Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 3
UserForm1.Controls("TextBox" & j).Value = Cells(i + 1, j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 2 To 3
UserForm1.Controls("TextBox" & j).Value = ""
Next j
End If
Else
ClearForm
End If
End Sub
This is my code for editing data
Sub EditAdd()
Dim emptyRow As Long
If UserForm1.TextBox1.Value <> "" Then
flag = False
i = 0
id = UserForm1.TextBox1.Value
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
Do While Cells(i + 1, 1).Value <> ""
If Cells(i + 1, 1).Value = id Then
flag = True
For j = 2 To 3
Cells(i + 1, j).Value = UserForm1.Controls("TextBox" & j).Value
Next j
End If
i = i + 1
Loop
If flag = False Then
For j = 1 To 3
Cells(emptyRow, j).Value = UserForm1.Controls("TextBox" & j).Value
Next j
End If
End If
End Sub
This is defined name of Datasource sheet
Name: data
=OFFSET(DataSource!$A:$A,1,0,COUNTA(DataSource!$A:$A)-1,1)
I have been given the task of searching through a large volume of
data. The data is presented identically across around 50 worksheets. I
need a macro which searches through all these sheets for specific
values then copies certain cells to a table created in a new workbook.
The macro also needs to create the table headings when it is run.
It must Search column G For the Value 9.1 Then certain information
must be copied to corresponding columns in the table
FHA Ref = Same row value from column G
Engine Effect = Same row value from column F
Part Number = Always cell J3
Part Name = Always cell C2
FM ID = Same Row value from Column B
Failure Mode & Cause = Same Row Value from Column C
FMCN = Same Row Value From Column C"`
If it is a hassle to create the new workbook with these column
headings then I would be quite happy to create the headings myself in
the worksheet and just have the macro search for and copy the data to
the rows corresponding to the headings.
If any help or backup files are needed I would be more than happy to
provide these.
the code I have at the moment is based on a userform also ideally I would do away with this and just search all sheets
Public Sub createWSheet(module, srcWBook)
Dim i
i = 0
srcWB = srcWBook
For Each ws In Workbooks(srcWBook).Worksheets
i = i + 1
If ws.Name = module Then
MsgBox ("A worksheet with for this module already exists")
Exit Sub
End If
Next ws
Workbooks(srcWBook).Activate
Worksheets.Add after:=Worksheets(i)
ActiveSheet.Name = module
Cells(2, 2) = "FHA Ref"
Cells(2, 3) = "Engine Effect"
Cells(2, 4) = "Part No"
Cells(2, 5) = "Part Name"
Cells(2, 6) = "FM ID"
Cells(2, 7) = "Failure Mode & Cause"
Cells(2, 8) = "FMCN"
Cells(2, 9) = "PTR"
Cells(2, 10) = "ETR"
Range(Cells(2, 2), Cells(2, 10)).Font.Bold = True
Range(Cells(1, 2), Cells(1, 10)) = "Interface"
Range(Cells(1, 2), Cells(1, 10)).MergeCells = True
Range(Cells(1, 2), Cells(1, 10)).Font.Bold = True
Workbooks(srcWBook).Activate
End Sub
Dim mainWB, srcWBook
Dim headerLeft, headerTop, headerBottom, headerRight
Dim nTargetFMECA, nPartID, nLineID, nPartNo, nPartName, nQTY, nFailureMode, nAssumedSystemEffect, nAssumedEngineEffect
Dim item As String
Dim mDest
Dim selections(100)
Public Sub controlCopyFMs(mWB, sWB, module)
Dim i
mainWB = mWB
srcWBook = sWB
mDest = 2
nTargetFMECA = 0
nPartID = 0
nLineID = 0
nPartNo = 0
nPartName = 0
nQTY = 0
nFailureMode = 0
nAssumedSystemEffect = 0
nAssumedEngineEffect = 0
For i = 0 To TestForm.LBSelected.ListCount - 1
Call copyFMs(module, selections(i))
Next i
End Sub
Public Sub copyFMs(module, comp)
Dim mSrc
Workbooks(srcWBook).Sheets(comp).Select
If exploreHeader(comp) = 0 Then
Exit Sub
End If
mSrc = headerBottom + 3
While Cells(mSrc, nSrc).Text <> ""
If Cells(mSrc, nIndication).Text <> "-" Then
If Cells(mSrc, nIndication).Text <> "" Then
Workbooks(mainWB).Worksheets(module).Cells(mDest, 2) = Cells(mSrc, nTargetFMECA).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 3) = Cells(mSrc, nPartID).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 4) = Cells(mSrc, nLineID).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 5) = Cells(mSrc, nPartNo).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 6) = Cells(mSrc, nPartName).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 7) = Cells(mSrc, nQTY).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 8) = Cells(mSrc, nFailureMode).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 9) = Cells(mSrc, nAssumedEngineEffect).Value
Workbooks(mainWB).Worksheets(module).Cells(mDest, 10) = Cells(mSrc, nAssumedSystemEffect).Value
mDest = mDest + 1
End If
End If
mSrc = mSrc + 2
Wend
End Sub
Public Function exploreHeader(comp)
Dim m, n
m = 1
n = 1
While ((InStr(1, Cells(m, n).Text, "Engine Programme:", vbTextCompare) <= 0) Or (InStr(1, Cells(m, n).Text, "BR700-725", vbTextCompare) <= 0)) And n < 10
If m < 10 Then
m = m + 1
Else
n = n + 1
m = 1
End If
Wend
headerTop = m
headerLeft = n
While StrComp(Cells(m, n).Text, "ID", vbTextCompare) <> 0 And StrComp(Cells(m, n).Text, "Case No.", vbTextCompare) <> 0
m = m + 1
Wend
headerBottom = m - 1
While Cells(m, n).Borders(xlEdgeBottom).LineStyle = xlContinuous
n = n + 1
Wend
headerRight = n - 1
m = headerTop
n = headerLeft
Do
If n > headerRight Then
n = headerLeft
m = m + 1
End If
If InStr(1, Cells(m, n).Value, "Item No.:", vbTextCompare) > 0 Then
item = Right(Cells(m, n).Value, Len(Cells(m, n).Value) - InStr(1, Cells(m, n).Value, ":", vbTextCompare))
Cells(m, n).Select
Exit Do
End If
n = n + 1
Loop While m <= headerBottom
m = headerBottom + 1
n = headerLeft
While n <= headerRight
If StrComp(Cells(m, n).Value, "ID", vbTextCompare) = 0 Then
nID = n
End If
If StrComp(Cells(m, n).Value, "Mitigation", vbTextCompare) = 0 Then
nMitigation = n
End If
If StrComp(Cells(m, n).Value, "Remarks", vbTextCompare) = 0 Then
nRemarks = n
End If
If StrComp(Cells(m, n).Value, "FMCN", vbTextCompare) = 0 Then
nFMCN = n
End If
If StrComp(Cells(m, n).Value, "Indication", vbTextCompare) = 0 Then
nIndication = n
End If
If StrComp(Cells(m, n).Value, "Crit", vbTextCompare) = 0 Then
nFMCN = n
End If
If StrComp(Cells(m, n).Value, "Detect", vbTextCompare) = 0 Then
nIndication = n
End If
If StrComp(Cells(m, n).Value, "Functional Description", vbTextCompare) = 0 Then
nMitigation = n
End If
n = n + 1
Wend
exploreHeader = 1
End Function
Public Sub initSelections()
For i = 0 To 99
selections(i) = ""
Next i
End Sub
Public Sub loadSelection(comp, i)
selections(i) = comp
End Sub
Public Sub deleteSelection(i)
While selections(i) <> ""
selections(i) = selections(i + 1)
i = i + 1
Wend
End Sub
I hope this can help more. This code may not work 100% but it should be good enough to guide you. Let me know if you have questions.
Dim WS As Worksheet
Dim Results(7, 1000000) As String ''Didn't know what is a good data type or how many possible results
Dim ColValue() As Variant
Dim I, II, ResultCt As Long
ResultCt = 0
For Each WS In ActiveWorkbook.Worksheets ''This should get all your result and information into the Results Array
ColValue = ActiveSheet.Range(Cells(2, 7), Cells(WS.UsedRange.Rows.Count, 7)).Value ''This put all of column G into an array
For I = 0 To UBound(ColValue)
If ColValue(I, 1) = "9.1" Then
Results(0, ResultCt) = Cells(I + 1, 7).Value ''I think it is off by 1, but if not remove the +1
Results(1, ResultCt) = Cells(I + 1, 6).Value
Results(2, ResultCt) = Cells(3, 10).Value
Results(3, ResultCt) = Cells(2, 3).Value
Results(4, ResultCt) = Cells(I + 1, 2).Value
Results(5, ResultCt) = Cells(I + 1, 3).Value
Results(6, ResultCt) = Cells(I + 1, 3).Value
ResultCt = ResultCt + 1
End If
Next
Next WS
''At this point us your code to create the worksheet and name it
''starting from the line Workbooks(srcWBook).Activate
''Then Set the Active cell to where ever you want to start putting the data and have something like
For I = 0 To UBound(Results, 2)
For II = 0 To UBound(Results)
ActiveCell.Offset(I, II).Value = Results(I, II) ''This assumes you put the information into Result in the order you want it printed out
Next
Next