I'm new to VBA and I find it rather difficult. I'm encountering what I think to be an easy problem, but I cannot manage to solve it.
I need to get the dates from different years (sheets) when the emission of a pollutant went over a certain limit(4 different limits). So I made a list on a cell which I named _YEAR and another list that I named _SEUIL. But for some reason, my code doesn't understand when I use the value of _YEAR to indicate the specific sheet I want to work on :/
This is my code :
Sub Recherche()
Dim i As Integer
Dim Y As String
Dim Ws As Worksheet
Y = CStr("_YEAR")
S = "_SEUIL" 'Entrée du seuil
SD = "_SORTIEDATE" 'Sortie des dates
SV = "_SORTIEVAL" 'Sortie des valeurs
SC = "_SORTIECOM" 'Sortie des commentaires
RD = Range(SD).Row
RV = Range(SV).Row
RC = Range(SC).Row
CD = Range(SD).Column
CV = Range(SV).Column
CC = Range(SC).Column
Set Ws = Worksheets(Y) 'This is the bug on my code
lastRow = Ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow Step 1
If Range(i, 3).Value > S Then
Range(RD + i, CD).Value = Range(i, 1).Value
Range(RV + i, CV).Value = Range(i, 3).Value
Range(RC + i, CC).Value = Range(i, 4).Value
End If
Next
MsgBox ("Execution terminée")
End Sub
Thank you very much for the help !
Related
I am trying to write a macro with some variables. Specifically worksheet names. Almost each time I have to find the correct worksheet name within the macro, so the worksheet names are coming from cell values. But referring a variable to another variable is giving an error.
Down below you can see the assign part of the codes. I am open to any suggestions.
Thank you so much..
Dim pLastRow As Long
Dim p As Integer
pLastRow = WorksheetFunction.Max(Worksheets(WS_All).Range("AA22:AA1100"))
pLastRow2 = pLastRow + 21
For p = 22 To pLastRow2
If Cells(p, 26).Value = "" Then
WS_1 = Worksheets(WS_All).Cells(p, 16).Value
WS_2 = Worksheets(WS_All).Cells(p, 19).Value
WS_3 = Worksheets(WS_All).Cells(p, 22).Value
End If
Dim j As Long
For j = 1 To 3
Dim j_WS As Variant
j_WS = "WS_" & j
MsgBox Worksheets(j_WS).Cells(1, 1).Value
o = 14 + j * 3
Dim WA1 As String
Dim WA2 As String
Dim WA3 As String
Gorev = Worksheets(WS_All).Cells(p, o).Value
SlideNo = Worksheets(WS_All).Cells(p, 34).Value
Egitim_Adi = Worksheets(WS_All).Cells(2, 3).Value
Dim Check1 As Range
Set Check1 = Worksheets(j_WS).Columns("A") 'Egitim_Adi Kontrolü için'
Dim Check2 As Range
Set Check2 = Worksheets(j_WS).Columns("B") 'SlideNo Kontrolü için'
Dim Check3 As Range
Set Check3 = Worksheets(j_WS).Columns("C") 'Gorev Kontrolü için'
I've found the solution with using array and using 3 cases for WS_1, 2 and 3.
I have a excel sheet looks like this: "Sheet1" & "Sheet2" and I wanted the result as shown in "Sheet3".
Sample Data
Eventually I would like to put a "Button" in a separate sheet (Control Panel) and when clicking on it I need to combine the data from "Sheet1" and "Sheet2" with the transpose effect as shown in "Sheet3".
How can I automate this using macro since there are ~2000 "rows" in Sheet 1 and ~1000 in Sheet 2. I'm new to macro so hopefully I can make this automated otherwise I'm copying and pasting all of them manually.
Thanks!
It might be helpful to use a function that returns the last row of a worksheet:
Public Function funcLastRow(shtTarget As Worksheet, Optional iColLimit As Integer = -1) As Long
If iColLimit = -1 Then
iColLimit = 256
End If
Dim rowMaxIndex As Long
rowMaxIndex = 0
Dim ctrCols As Integer
For ctrCols = 1 To iColLimit
If shtTarget.Cells(1048576, ctrCols).End(xlUp).Row > rowMaxIndex Then
rowMaxIndex = shtTarget.Cells(1048576, ctrCols).End(xlUp).Row
End If
Next ctrCols
funcLastRow = rowMaxIndex
End Function
You could use it simply like so:
Dim lLastRow As Long
lLastRow = funcLastRow(Sheets(1))
Please let us know if that worked for you thanks
Here is an all formula solution (No Macro)
Data is in Sheet1 A to I and Sheet2 A to G
I am assuming you have only 6 departments. although if you have additional, the formulas need very little or may be no modification.
In Sheet 3
Get the userID repeated six times
A2 = INDEX(Sheet1!A:A,1+QUOTIENT(ROW()-ROW($A$2)+6,6))
Get Name, Gender & Country
B2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:B$1),FALSE)
C2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:C$1),FALSE)
D2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:D$1),FALSE)
Get Access to department. The "" & ... is to avoid 0 in case the resulting cell was blank.
E2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,HLOOKUP(F2,Sheet1!$A$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0),FALSE),HLOOKUP(F2,Sheet2!$A$1:$G$3000,MATCH(A2,Sheet2!$A$1:$A$3000,0),FALSE))
F2:F7 the departments are Input manually (no formula). F8 is linked to F2 so that the depts repeat when dragged down
G2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,INDEX(Sheet1!$I$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)),INDEX(Sheet2!$G$1:$G$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)))
If you need, I can prepare a google sheet to demo. Cheers.
This code works very well for Transpose and concatenate of big data.
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub
i am having troubles after fixing next variable issues. I am now getting run time errors 424. I believe this is because i am not naming my variables correctly as strings or Integers. I have two methods to the code and they are both resulting in the same error.
Columns 11 and 1 are text that need to match
Column 10 and columns(v) are dates that need to match
Column 2 will be text with a number at the end
Columns(V) will be a number with a number at the end
the logic of the loop makes sense to me but can't figure out what's causing the issue.
If cell.Value(J, 11) = Master.cell.Value(P, 1) And cell.Value(J, 10) = Master.cell.Value(P, V) Then
error Produced here "Run time '424' Object Required, What object am i missing? (error in bold)
Sub IndexInfo()
'
' Loops through data and finds matches and then indexs information
'
Dim J As Integer
Dim P As Integer
Dim V As Integer
Dim Master As Worksheet
Dim Gracie As Worksheet
IRowL = Cells(Rows.Count, 1).End(xlUp).Row
Set Master = Worksheets("Master")
Set Gracie = Worksheets("Gracie")
For J = 2 To IRowL
For V = 21 To 50
For P = 2 To IRowL
If Gracie.Cells(J, 11).Value = Master.Cells(P, 1).Value And Gracie.Cells.Value(J, 10) = Master.Cells(P, V).Values Then
Gracie.Cells(J, 30).Value = Master.Cells(P, 2).Value And Gracie.Cells(J, 31).Value = Master.Cells(1, V).Value
Else
End If
Next P
Next V
Next J
End Sub
I am using Excel 2010.
I have some working VBA code that compares two cells (from text, to text) and generates the redlined text into a third cell with strikethroughs on removed words, underlines on added words. This is not a straight combination of the contents of the cells.
The code works, but I think it can be more efficient with the use of multidimensional arrays to store things instead of using additional cells and recombining. But I am stuck on how to implement it. I would also like to determine where the breaking point is, especially for newer versions of Excel that I don't have yet, since the number of characters allowed in a cell seems to continually grow with every new release.
Comments are also welcome.
The working code:
Sub main()
Cells(3, 3).Clear
Call Redline(3)
End Sub
Sub Redline(ByVal r As Long)
Dim t As String
Dim t1() As String
Dim t2() As String
Dim i As Integer
Dim j As Integer
Dim f As Boolean
Dim c As Integer
Dim wf As Integer
Dim ss As Integer
Application.ScreenUpdating = False
t1 = Split(Range("A" + CStr(r)).Value, " ", -1, vbTextCompare)
t2 = Split(Range("B" + CStr(r)).Value, " ", -1, vbTextCompare)
t = ""
f = False
c = 4
ss = 0
If (Range("A" + CStr(r)).Value <> "") Then
If (Range("B" + CStr(r)).Value <> "") Then
j = 1
For i = LBound(t1) To UBound(t1)
f = False
For j = ss To UBound(t2)
If (t1(i) = t2(j)) Then
f = True
wf = j
Exit For
End If
Next j
If (Not f) Then
Cells(r, c).Value = t1(i)
Cells(r, c).Font.Strikethrough = True ' strikethrough this cell
c = c + 1
Else
If (wf = i) Then
Cells(r, c).Value = t1(i) ' aka t2(wf)
c = c + 1
ss = i + 1
ElseIf (wf > i) Then
For j = ss To wf - 1
Cells(r, c).Value = t2(j)
Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell
c = c + 1
Next j
Cells(r, c).Value = t1(i)
c = c + 1
ss = wf + 1
End If
End If
Next i
If (UBound(t2) > UBound(t1)) Then
For i = ss To UBound(t2)
Cells(r, c).Value = t2(i)
Cells(r, c).Font.Underline = xlUnderlineStyleSingle ' underline this cell
c = c + 1
Next i
End If
Else
t = Range("A" + CStr(r)).Value
End If
Else
t = Range("B" + CStr(r)).Value
End If
lc = Range("XFD" + CStr(r)).End(xlToLeft).Column
Call Merge_Cells(r, 4, lc)
Application.ScreenUpdating = True
End Sub
Sub Merge_Cells(ByVal r As Long, ByVal fc As Integer, ByVal lc As Long)
Dim i As Integer, c As Integer, j As Integer
Dim rngFrom As Range
Dim rngTo As Range
Dim lenFrom As Integer
Dim lenTo As Integer
Set rngTo = Cells(r, 3)
' copy the text over
For c = fc To lc
lenTo = rngTo.Characters.Count
Set rngFrom = Cells(r, c)
lenFrom = rngFrom.Characters.Count
If (c = lc) Then
rngTo.Value = rngTo.Text & rngFrom.Text
Else
rngTo.Value = rngTo.Text & rngFrom.Text & " "
End If
Next c
' now copy the formatting
j = 0
For c = fc To lc
Set rngFrom = Cells(r, c)
lenFrom = rngFrom.Characters.Count + 1 ' add one for the space after each word
For i = 1 To lenFrom - 1
With rngTo.Characters(j + i, 1).Font
.Name = rngFrom.Characters(i, 1).Font.Name
.Underline = rngFrom.Characters(i, 1).Font.Underline
.Strikethrough = rngFrom.Characters(i, 1).Font.Strikethrough
.Bold = rngFrom.Characters(i, 1).Font.Bold
.Size = rngFrom.Characters(i, 1).Font.Size
.ColorIndex = rngFrom.Characters(i, 1).Font.ColorIndex
End With
Next i
j = j + lenFrom
Next c
' wipe out the temporary columns
For c = fc To lc
Cells(r, c).Clear
Next c
End Sub
You can directly assign Excel Range object to VBA 2d-array and perform all that business logic operations on that array. It will provide substantial performance boost vs range iteration. The result values then can be inserted back into Excel worksheet column from that 2d-array.
Sample code snippet follows:
Sub Range2Array()
Dim arr As Variant
arr = Range("A:B").Value
'alternatively
'arr = Range("A:B")
'test
Debug.Print (arr(1, 1))
End Sub
Another useful technique is to assign Excel's UsedRange to VBA Array:
arr = ActiveSheet.UsedRange
Hope this may help. Best regards,
Sample code not quite right
I've got a spreadsheet with the following "original" and "changed" content:
Tesla to Begin Trial for Allowing Other Vehicles from Other Electric Vehicle Automakers to Use Tesla Superchargers
Tesla to Begin Trial for Allowing Other Vehicles from Other EV Auto Makers to Use Tesla Superchargers
Running your code, I got not-quite-right results.
The "original" text that is missing from the "changed" version is correctly shown with strikethrough, but the new text in the "changed" version is just ... missing.
Alternative approach
Poking around, it looks like you're trying to re-create MS Word's Track Changes formatting.
Why not just leverage Word?
The following VBA code does just that. This requires that your Excel VBA project has a reference to the Word object library. You can add this from within the VBA editor by clicking Tools → References, and selecting Microsoft Word XX.Y Object Library, where XX.Y is whatever version you have installed.
Public Sub CompareCells()
' ####################
' Basic Flow
'
' 1. Get the text content of the two cells to compare.
' 2. Get an open instance of MS Word, or spin up a new one.
' 3. Use Word's text-comparison features to generate the tracked-changes markup.
' 4. Copy that markup to the clipboard.
' 5. Then just paste that into our target cell.
' ####################
Const Src As String = "A" ' Column containing the original source text
Const Tgt As String = "B" ' Column containing the targeted text to compare
Const Cmp As String = "C" ' Column where we will put the marked-up comparison
Const RowToUse As Integer = 8 ' Rejigger as appropriate to your use case.
' 1.
Dim ThisSheet As Excel.Worksheet: Set ThisSheet = Excel.ActiveSheet
Dim StrSrc As String, StrTgt As String
StrSrc = ThisSheet.Range(Src & RowToUse).Value
StrTgt = ThisSheet.Range(Tgt & RowToUse).Value
' 2.
Dim Wd As Word.Application: Set Wd = GetApp("Word")
' 3.
Dim DocOrig As Word.Document, DocChgd As Word.Document, DocMarkup As Word.Document
Set DocOrig = Wd.Documents.Add(Visible:=False)
DocOrig.Content = StrSrc
Set DocChgd = Wd.Documents.Add(Visible:=False)
DocChgd.Content = StrTgt
Set DocMarkup = Wd.CompareDocuments(DocOrig, DocChgd, wdCompareDestinationNew)
' 4.
DocMarkup.Content.Copy
' 5.
ThisSheet.Range(Cmp & RowToUse).Select
ThisSheet.Paste
' Cleanup
DocOrig.Close savechanges:=False
DocChgd.Close savechanges:=False
DocMarkup.Close savechanges:=False
End Sub
Public Function GetApp(AppName As String) As Object
Dim app As Object
On Error GoTo Handler
Set app = GetObject(, AppName & ".Application")
Set GetApp = app
Exit Function
On Error GoTo 0
Handler:
If Err.Number > 0 And Err.Number <> 429 Then ' Unknown error, so error out
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Exit Function
End If
DoEvents
' If we get here, there's no open app by that name, so start a new instance.
Set app = CreateObject(AppName & ".Application")
Set GetApp = app
End Function
When run using the same sample texts, I get the following:
This time, we get both the removed text in strikethrough, and the added text in underlining, with color coding as well.
I have a userform where the user inputs data and then clicks the button Add.
The VBA then creates a new row and inputs the data from the user into that row.
This works fine, however I want to also add a new row in a different sheet as well and this is where I am stuck.
This is my code:
Dim i As String
Dim j As String
Dim k As String
Dim m As String
Dim n As String
j = XIDBox.Value
i = OrgNameBox.Value
k = ContactNameBox.Value
m = PhoneBox.Value
n = EmailBox.Value
dstRw = Sheets("Input Data").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Input Data").Cells(dstRw, 1).Value = i
Sheets("Input Data").Cells(dstRw, 2).Value = j
Sheets("Input Data").Cells(dstRw, 4).Value = k
Sheets("Input Data").Cells(dstRw, 6).Value = m
Sheets("Input Data").Cells(dstRw, 5).Value = n
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
The process is very similar to what you have in place.
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
Dim otherSheet As Worksheet
Set otherSheet = Sheets("Other Sheet Name")
' Insert as the last row.
Dim otherRow As Long
otherRow = otherSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
' Now write the values.
otherSheet.Cells(otherRow, 1).Value = i
otherSheet.Cells(otherRow, 2).Value = j
otherSheet.Cells(otherRow, 4).Value = k
otherSheet.Cells(otherRow, 6).Value = m
otherSheet.Cells(otherRow, 5).Value = n
This works for both sheets using an array for your sheets. You can expand it by adding items to the array in the same manner. You also don't need to store the values as variables, since the name of the object is small, you can just set the cell's values directly from the source.
This finds the last row for each sheet, adds 1 and then sets the values of the cells from your source objects. Then loops the process for the next sheet in the array.
TESTED:
Sub ValueMove()
Dim dstRw As Long
Dim sheet(1) As String
sheet(0) = "Input Data"
sheet(1) = "Different Sheet"
For s = 0 To 1
dstRw = Sheets(sheet(s)).Range("A" & Rows.count).End(xlUp).row + 1
Sheets(sheet(s)).Cells(dstRw, 1).Value = OrgNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 2).Value = XIDBox.Value
Sheets(sheet(s)).Cells(dstRw, 4).Value = ContactNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 6).Value = PhoneBox.Value
Sheets(sheet(s)).Cells(dstRw, 5).Value = EmailBox.Value
Next s
End Sub