Related
When trying to run the below code, a compile error of for without next or next without for is experienced. The error message keeps appearing in loops (once a for without next error, the next time a next without for error), making it difficult to spot where the error is.
How to check if an "end if" is missing or if there is an indentation error?
Please help!
Sub DataCleaning()
Dim ws As Worksheet
Dim myValue As Variant
Dim StringToFind As String
Dim f, cell, cell1 As Range
Dim LastCol, LastCol1 As Long
Dim i, j, k, l As Integer
Application.DisplayAlerts = False 'Optional
For Each ws In Worksheets
Select Case ws.Name
'Include sheet names to keep on next line (with comma between)
Case "VIE", "CA", "UK", "EU", "CHN", "JP", "AU", "NZ", "KR", "PH", "TH", "ID"
ws.Cells.ClearFormats
Case Else
ws.Delete
End Select
Next ws
Application.DisplayAlerts = True
StringToFind = Application.InputBox("Input Batch Number:")
For Each ws In Worksheets
'myValue = InputBox("Input Batch Number:", ws, 1)
ws.Activate
ActiveSheet.Rows(4).Select
Set cell = Selection.Find(what:="Batch " & StringToFind, After:=ActiveCell, _
LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
MsgBox "No Order"
Else
cell.Offset(0, -1).Select
ColumnLetter = Split(Cells(1, ActiveCell.Column).Address, "$")(1)
Range(Columns("B"), Columns(ColumnLetter)).EntireColumn.Delete
LastCol = Cells(5, Columns.Count).End(xlToLeft).Column
ws.Activate
ActiveSheet.Rows(5).Select
Set cell1 = Selection.Find(what:="<", After:=ActiveCell, _
LookIn:=xlFormulas, lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
cell1.Select
ColumnLetter1 = Split(Cells(1, ActiveCell.Column).Address, "$")(1)
Range(Cells(1, ColumnLetter1), Cells(1, LastCol)).EntireColumn.Delete
Rows(1).EntireRow.Delete
Range("A1") = "Batch"
Range("A2") = "City"
Range("A3") = "Number"
Range("A4") = "Shipment"
LastCol1 = Cells(4, Columns.Count).End(xlToLeft).Column
With Range("B1")
For j = 2 To LastCol1
Cells(1, j) = StringToFind
Next j
End With
With Range("B2")
For k = 2 To LastCol1
Cells(2, k) = ws.Name
Next k
End With
With Range("B3")
For l = 2 To LastCol1
Cells(3, l) = ""
Next l
End With
Cells(4, LastCol1 + 1) = "Price"
i = 1
Do While Not IsEmpty(Cells(i, 1))
SKUColumn = Cells(i, 1)
If SKUColumn Like "2018" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
ElseIf SKUColumn Like "2020" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
ElseIf SKUColumn Like "Accessories" Then
ws.Rows([i]).EntireRow.Delete
Deleted = True
End If
i = i + 1
Loop
Application.ScreenUpdating = True
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\xxx\Desktop\" & ws.Name & ".csv" _
, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close SaveChanges:=True
Application.ScreenUpdating = False
Next ws
End If 'this line should be in front of `Next ws`
I havethe following problem:
To be able to deploy multiple devices, I have edited some VBA code I found here and there and I'm lost at the moment... Because I'm not a coder, and I don't understand exactly what the code does, I can't figure out the solution.
The problem is: when I add 1 device, the .csv file is cluttered with data:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
#N/A,,,#N/A,,STOCK,
(etc)
When I add 2 or more devices, the .csv file is OK:
HOSTNAMEHQ,COUNTRYCRE,HARDWARECRE,MAC,UUID,DESCRIPTION,PLATFORM
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
LPAB00000013293,,,28:F1:0E:30:81:C1,,STOCK,
The code I'm using is:
Sub Button_Click()
Call SaveWorksheetsAsCsv
End Sub
Sub SaveWorksheetsAsCsv()
On Error Resume Next
Dim i As Long
Errorknop = vbCritical + vbOKOnly
ThisWorkbook.Sheets("Export").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export").Activate
Range("A1").Select
Selection.End(xlDown).Select
LaRo = ActiveCell.Row
Range("A1").Select
Range("A2").Select
Selection.End(xlDown).Select
LR = ActiveCell.Row
LC = Last(4, ActiveSheet.Cells)
LCR = LC & LR
Range("B1:" & LCR).Copy
ThisWorkbook.Sheets("Export").Visible = xlSheetHidden
ThisWorkbook.Sheets("Export_2").Visible = xlSheetVisible
ThisWorkbook.Sheets("Export_2").Activate
Range("A1").Select
Range("A1").PasteSpecial Paste:=xlPasteValues
Dim LValue As Date
LValue = Now
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim strbody As String
Dim SigString As String
Dim Signature As String
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "D:\Testmap\Formulieren\"
Worksheets("Export_2").SaveAs Filename:=SaveToDirectory & Day(LValue) & Month(LValue) & Year(LValue) & Hour(LValue) & Minute(LValue) & Second(LValue) & "_1IMPORT_TEMPLATE_NN_AD_SCCM_HP", FileFormat:=xlCSV
ThisWorkbook.Saved = True
Application.Quit
End Sub
Function Last(choice As Integer, rng As Range)
' 1 = last row
' 2 = last column (R1C1)
' 3 = last cell
' 4 = last column (A1)
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Last = Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
Case 4:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Last = R1C1converter("R1C" & Last, 1)
For i = 1 To Len(Last)
s = Mid(Last, i, 1)
If Not s Like "#" Then s1 = s1 & s
Next i
Last = s1
End Select
End Function
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function R1C1converter(Address As String, Optional R1C1_output As Integer, Optional RefCell As Range) As String
'Converts input address to either A1 or R1C1 style reference relative to RefCell
'If R1C1_output is xlR1C1, then result is R1C1 style reference.
'If R1C1_output is xlA1 (or missing), then return A1 style reference.
'If RefCell is missing, then the address is relative to the active cell
'If there is an error in conversion, the function returns the input Address string
Dim x As Variant
If RefCell Is Nothing Then Set RefCell = ActiveCell
If R1C1_output = xlR1C1 Then
x = Application.ConvertFormula(Address, xlA2, xlR1C1, , RefCell) 'Convert A2 to R1C1
Else
x = Application.ConvertFormula(Address, xlR1C1, xlA2, , RefCell) 'Convert R1C1 to A2
End If
If IsError(x) Then
R1C1converter = Address
Else
'If input address is A1 reference and A1 is requested output, then Application.ConvertFormula
'surrounds the address in single quotes.
If Right(x, 1) = "'" Then
R1C1converter = Mid(x, 2, Len(x) - 2)
Else
x = Application.Substitute(x, "$", "")
R1C1converter = x
End If
End If
End Function
For a coder this might be completely logical or even a big mess, but I really hope someone can give me the solution so the script runs, get's the information for the cells, and then stops when it finds an empty cell. At that moment, write the .csv file and close.
I found the solution using a step-by-step method with F8. Finding the last row was where the error was. Now I'm using:
Cells(Rows.Count, "A").End(xlUp).Row
I know how to find the last row, and add a SUM() to that, but how do I SUM(G+H) in column O for each row of the used range?
I would use this to get the last row and sum columns, how could this be converted to sum rows?
With ws
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
.Range("C" & LastRow + 1).FormulaR1C1 = "=SUM(R[-" & LastRow & "]C:R[-1]C)"
.Range("C" & LastRow + 1 & ":M" & LastRow + 1).FillRight
End With
Something like this would get G + H in column O:
Sub testme()
Dim l_counter As Long
For l_counter = 1 To 100
ActiveSheet.Cells(l_counter, 15).FormulaR1C1 = "=RC7+RC8"
Next l_counter
End Sub
Just make sure that you change the 100 to a variable, in your case, LastRow
I have created a userform and one of the commandbuttons launches another userform in which data can be entered into. This data is then added to a table in a worksheet, the userform is then unloaded and the user is returned to the original userform. The error occurs when the data is meant to be entered into the worksheet. This userform works perfectly on its own, but when it is launched from the first userform, this is when the error occurs.
Private Sub CommandButton1_Click()
'check all fields are filled
Dim nextRow As Integer
Dim nextCell As String
If Len(Trim(ComboBox1.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
If Len(Trim(TextBox1.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
If Len(Trim(TextBox2.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
'Check if supplier ID already exists
Dim FindString As String
Dim Rng As Range
FindString = TextBox1.Value
If Trim(FindString) <> "" Then
With Sheet4.Range("B:B")
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
Application.Goto Rng, False
MsgBox "Sorry Bro, " & FindString & " already exists!"
Exit Sub
Else
FindString = TextBox2
If Trim(FindString) <> "" Then
With Sheet4.Range("D:D")
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
Application.Goto Rng, False
MsgBox "Sorry Bro, the Ordering Details you entered:" & vbNewLine & _
"'" & FindString & "'" & vbNewLine & _
"Already exists in our Database!" & vbNewLine & _
"U wanna check ur data?"
Exit Sub
End If
End With
End If
End If
End With
End If
'enter supplier ID into sheet
Sheet4.Activate
nextRow = ActiveSheet.Range("B2", Range("B2").End(xlDown)).Count
nextCell = Cells(nextRow + 2, 2).Activate
'this is where the error occurs
ActiveCell.Value = TextBox1.Value
ActiveCell.Offset(0, 1).Value = ComboBox1.Value
ActiveCell.Offset(0, 2).Value = TextBox2.Value
Sheet2.Activate
Unload Me
End Sub
I'm not sure why it doesn't work because personally I avoid the use of "Activate". Maybe you can try if this works:
'Previous code that worked fine
nextRow = ActiveSheet.Range("B2", Range("B2").End(xlDown)).Count
With ActiveSheet.Cells(nextRow + 2, 2)
.Value = TextBox1.Value
.Offset(0, 1).Value = ComboBox1.Value
.Offset(0, 2).Value = TextBox2.Value
End With
Sheet2.Activate
Unload Me
End Sub
Hope this does the job! (Note that this is my first answer so I'm very open to feedback)
have to replace the word in excel cell .
using like
Sub test()
Dim a_row As String
Dim b_row As String
Dim row_counter As Integer
For row_counter = 1 To 600
a_row = "A" & row_counter
b_row = "B" & row_counter
Dim Findtext As String
Dim Replacetext As String
Findtext = Sheets("sheet1").Range(a_row).Value
Replacetext = Sheets("sheet1").Range(b_row).Value
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveWorkbook.Worksheets(1).Name Then
ws.Cells.Replace What:=Findtext, Replacement:=Replacetext, LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End If
Next ws
Next row_counter
End Sub
there are two cols in sheet1. 1st cols shows Japanese words. 2nd column shows English words.
公園 park
夏 summer
緑 Green
青空 blue Sky
男の人 man
In the 2nd sheet displays in col A
column A
公園、夏、青空、緑、男の人
the above code replace Japanese words.
if LookAt:= _xlPart, after replace shows like below
park, summer, 青sky, green,manの人
if LookAt:= _xlWhole , its not replacing the word
In the 2nd sheet displays in the separate columns
A B C D E
公園 夏 青空 緑 男の人
if LookAt:= _xlWhole then
its working perfectly.
i want to do
In the 2nd sheet displays the value in single col A delimited by comma
column A
公園、夏、青空、緑、男の人
need the output like
park, summer, blue sky, green,man
please give some idea.. thanks
Do it in memory instead, it's quicker and much easier to work with arrays. If I understand the way your data is set out - the following should work where your find/replace table is in columns A:B on sheet1 and the values to replace are in sheet2 and are comma separated in cell A1:
Sub MM_Foo()
Dim findArray As Variant
Dim replaceArray As Variant
Dim matchPosition As Long
With Sheets(1)
findArray = .Range("A1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
End With
On Error GoTo checkErr:
For j = 1 To Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).Row
replaceArray = Split(Sheets(2).Cells(j, 1).Value, ",")
With Application
For i = LBound(replaceArray) To UBound(replaceArray)
matchPosition = .Match(replaceArray(i), .Index(findArray, , 1), 0)
replaceArray(i) = findArray(matchPosition, 2)
skipReplace:
Next
End With
Sheets(2).Cells(j, 1).Value = Join$(replaceArray, ",")
Next
On Error GoTo 0
Exit Sub
checkErr:
If Err.Number = 13 Then
Err.Clear
GoTo skipReplace:
Else
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "Error"
Err.Clear
On Error GoTo 0
Exit Sub
End If
End Sub
Without a trailing 'comma', there may have to be repetitive passes that may or may not actually do anything; there need to cover all possible combinations.
Sub delimitedTranslate()
Dim w As Long, vWRDs As Variant
With Worksheets("Sheet1")
vWRDs = .Range(.Cells(2, "A"), _
.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1)) _
.Value2
End With
With Worksheets("Sheet2")
With .Columns("A")
For w = LBound(vWRDs, 1) To UBound(vWRDs, 1)
.Replace what:=vWRDs(w, 1) & ChrW(12289), _
replacement:=vWRDs(w, 2) & Chr(44), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=ChrW(12289) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
.Replace what:=Chr(44) & vWRDs(w, 1), _
replacement:=Chr(44) & vWRDs(w, 2), _
lookat:=xlPart, MatchCase:=False, searchformat:=False
Next w
End With
End With
End Sub
Sheet1 terms Sheet2 before delimitedTranslate Sheet2 after delimitedTranslate