I have the following issue. I have several source file to copy from into my summary sheet (the order of columns/rows can differ). Thus, I am trying to do some hard-coded check with a h/v-lookup combo. The code is the following:
For i = 2 To Row_number
'''' 1150 ''''
If (Cells(i, 42).Value = "1150") Then
If (WB_1150 Is Nothing) Then
Set WB_1150 = Workbooks.Open(directory & file_1150)
For Each wb In Workbooks
If (wb <> ThisWorkbook & wb <> WB_1150) Then
wb.Close savechanges = False
End If
Next wb
End If
bool_vlookup_result = IsError(Application.vlookup(ThisWorkbook.Sheets(sheet_name_swaption).Cells(i, 12), WB_1150.Sheets(1).range("V1:V" & Row_number), 1, False))
If (bool_vlookup_result = True) Then
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "ERROR"
Next i
Else
row_index_result = Application.Match(Cells(i, 2), WB_1150.Sheets(1).range("V1:V" & Row_number), 0)
For j = 1 To 42
If (Cells(row_index_result, j) = "") Then
Next j
Else
bool_hlookup_result = IsError(Application.HLookup(ThisWorkbook.Sheets(sheet_name_swaption).Cells(i, j), WB_1150.Sheets(1).range(Cells(row_index_result, 1), Cells(row_index_result, 22)), 1, False))
If (bool_hlookup_result = True) Then
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "ERROR"
Next i
End If
End If
Next j
ThisWorkbook.Activate
Sheets(sheet_name_swaption).Activate
Cells(i, 43).Value = "OK"
End If
End If
'''' End 1150 ''''
''' OTHER SOURCE FILES '''
Next i
I get the error Next without For, because as soon as I got an error I can skip to the following i/j. Any suggestions to solve/improve this? I know that there can be several ways to do those checks, but this is the most powerful (and most time-consuming though) instrument that I found. Many thanks in advance.
You can do it in such way:
For i = 1 To 10
If i = 3 Then GoTo Cont
Debug.Print i
Cont:
Next i
Related
I have this VBA code which ends right after the big for loop, before "msgbox "h". The msgbox is to check if it continues. The code runs through the loop but nothing more. Can someone please help me understand why?
Sub countPT()
'Select file
Application.ScreenUpdating = False
Dim i As Integer, lastRow As Integer, tellerPoE(13) As Integer,
telleruPoE(13) As Integer, SwitchInd As Integer
Dim wb As Workbook, wb2 As Workbook
Dim krrom As String, Comment As String
For i = 1 To 13
tellerPoE(i) = 0
telleruPoE(i) = 0
Next i
Set wb = ActiveWorkbook
openFile = Application.GetOpenFilename("Excel-files,*.xls*", 1, _
"Select a file to open", , False)
Application.ScreenUpdating = False
If Len(openFile) = 0 Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
End
End If
Workbooks.Open openFile
Set wb2 = ActiveWorkbook
'Read through and count -> put to array on index
lastRow = wb2.Worksheets("Rådata").Range("F" & Rows.Count).End(xlUp).Row
For i = 114 To lastRow
wb2.Activate
If CStr(wb2.Worksheets("Rådata").Cells(i, "G")) = "528" Then
krrom = CStr(wb2.Worksheets("Rådata").Cells(i, "F"))
SwitchInd = SwitchCode(krrom)
'If SwitchInd = 0 Then
'GoTo ContinueLoop
'End If
Comment = LCase(CStr(wb2.Worksheets("Rådata").Cells(i, "M")))
If (InStr(Comment, "poe") Or InStr(Comment, "kamera") Or
InStr(Comment, "cam")) Then
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
End If
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
Else
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
'ContinueLoop
End If
Next i
'Check up to existing
'Update values
'Give message on change
MsgBox "h"
For j = 1 To 13
If tellerPoE(j) > CInt(Cells(5 + j, "E")) * 2 Or telleruPoE(j) >
CInt(Cells(5 + j, "G")) Then
Cells(6 + j, "K") = "Punkter økt"
End If
Cells(5 + j, "E") = tellerPoE(j)
Cells(5 + j, "G") = telleruPoE(j)
Next j
'Empty and close
Application.CutCopyMode = False
Set wb = ActiveWorkbook
wb2.Close
Application.ScreenUpdating = True
End Sub
Some of the code are commented out as to try to fix the problem or make it easier to find blocks
After the MsgBox, delete the loop and write the following:
MsgBox "h"
For j = 1 To 13
Cells(6 + j, "K") = "Punkter økt"
Next j
check whether it produces what you need. If it does, then it works and your condition is wrong.
The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 for each manager).
The file: - Many different tabs, separated by role. - First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager
The task: John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role.
Based on that sample data, the ideal macro would give me 3 files with 3 worksheets in each, and 1 row of data in each worksheet. However, I will settle for the worksheet being split into multiple files.
Here is my code.
Sub SplitWB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Save
Dim OutputFolderName As String
OutputFolderName = ""
Set myDlg = Application.FileDialog(msoFileDialogFolderPicker)
myDlg.AllowMultiSelect = False
myDlg.Title = "Select Output Folder for Touchstone Files:"
If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub
Set myDlg = Nothing
Application.CutCopyMode = False
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Dim d As Object, c As Range, k, tmp As String, unique(500)
i = 0
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set d = CreateObject("scripting.dictionary")
For Each c In Range(Cells(1, 1), Cells(lastRow, 1))
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
i = i + 1
unique(i) = k
Next k
UniqueCount = i
'start deleting
For i = 1 To UniqueCount
'Actions for new workbook
wpath = Application.ActiveWorkbook.FullName
wbook = ActiveWorkbook.Name
wsheet = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
For j = 1 To lastRow
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
j = j - 1
End If
Next
'hide helper columns
' If HideC = False And DeleteC = True Then
Columns("A:D").Hidden = True
' End If
'
Range("E8").Select
'Select Instructions tab
'Worksheets("Guidelines").Activate
'Save new workbook
ActiveWorkbook.Close SaveChanges:=True
Workbooks.Open (wpath)
'ActiveWorkbook.Close False
Workbooks(wbook).Activate
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName)
End Sub
The code hangs at "If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then"
It is located about half-way into the code and the chunk starts with "For j = 1 To lastRow"
Please help. It will literally save me a day's work or more. Thanks!!!
Try
For j = lastRow to 1 step -1
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
End If
Next
instead. This allows you to loop backwards so when you delete a row it won't lose track of where you want j to be in the loop.
I am trying to copy one row to an other workbook (only if there is a match) and i can accomplish that with a simple loop but i would like to use some better and possibly quicker method:
Set wbk = Workbooks.Open(FROM)
Set wskz = wbk.Worksheets("Sheet1")
Set wbi = Workbooks.Open(TO)
Set wski = wbi.Worksheets("Sheet1")
si = 5
Do While wski.Cells(si, 1).Text <> "END" ' loop through the values in column "A" in the "TO" workbook
varver = wski.Cells(si, 1).Text ' data to look up
s = 5
Do While wskz.Cells(s, 1).Text <> "END" ' table where we search for the data in the "FROM" workbook
If wskz.Cells(s, 1).Text = varver Then Exit Do
s = s + 1
Loop
If wskz.Cells(s, 1).Text <> "END" Then
' I am trying this copy method to replace the loop but it throws an error
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
' this is the working loop:
'For i = 1 To 250
' wskz.Cells(s, i) = wski.Cells(si, i)
' i = i + 1
'End If
'Next i
The problem with the new copying method throws an error as it can be seen above.
Thank you in advance for your help!
Try to replace :
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
by
wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250)).Copy Destination:=wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Or by :
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250))
Set Rng2 = wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Rng1.Copy Rng2
This should do exactly what you are looking for:
Sub test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim SourceWS As Worksheet, DestWS As Worksheet
Set SourceWS = Workbooks.Open("FROM").Worksheets("Sheet1")
Set DestWS = Workbooks.Open("TO").Worksheets("Sheet1")
Dim runner As Variant, holder As Range
If IsError(Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0)) Or IsError(Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0)) Then
SourceWS.Parent.Close False
DestWS.Parent.Close False
Exit Sub
End If
Set holder = DestWS.Range("A5:A" & Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0) + 3)
For Each runner In SourceWS.Range("A5:A" & Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0) + 3)
If IsNumeric(Application.Match(runner.Value, holder, 0)) Then runner.EntireRow.Copy DestWS.Rows(Application.Match(runner.Value, holder, 0) + 4)
Next
SourceWS.Parent.Close True
DestWS.Parent.Close True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
It is self-explaining to my eye, but if you have any questions, just ask :)
This Error often occures related to Copy-Methods. I also ran into this kind of Error when I had my Sub on Worksheet Level. Try to extract it to a seperate Modul.
Also it seems your references to the Cells are broken. You can find this explained in the docs for Range.Item.
Try this
With wskz
.Range(.Cells(s, 1), .Cells(s, 250)).Copy
End With
I have an Excel dataset that has a string in A1, and other values in B1, B2, and B3 that relate to A1; and so on down the page. Sometimes there are more than three cells that relate to the other string (unpredictable). In this example, cells A2 and A3 are blank. I want to create a macro that will fill A2 and A3 (etc) with the contents of A1.
In the example below I am using [] to help format it as Excel cells. I want to go from:
[SMITH, John] [Home]
[Mobile]
[Work]
[DOE, John] [Home]
[Mobile]
to
[SMITH, John] [Home]
[SMITH, John] [Mobile]
[SMITH, John] [Work]
[DOE, John] [Home]
[DOE, John] [Mobile]
I want the macro to repeat this for varying iterations, sometimes I have 1000 lines to adjust manually. Tweaking the software that outputs the data is not an option.
The code I have is as follows:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1,0) = "" Then
ActiveCell.Offset(1,0) = cellvar
i = i + 1
ElseIf ActiveCell.Offset(1,0) = "*" Then
ActiveCell.Offset(1,0).Activate
i = i + 1
End If
Wend
End Sub
The above code adds text to the cell below the active cell once and then stops responding. The following code runs once and doesn't stop responding - I can run it again, but it doesn't automatically move down a row.
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 1
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If ActiveCell.Offset(1, 0) = "*" Then
ActiveCell.Offset(1, 0).Select.Activate 'I have tried .Offset(2,0)too
End If
i = i + 1
Next
End Sub
I am stumped here. Does anyone have any thoughts or suggestions?
Try it as,
Sub fillBlanks()
With Worksheets("Sheet1")
With .Range(.Cells(2, "B"), .Cells(Rows.Count, "B").End(xlUp))
With .Offset(0, -1).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
With .Offset(0, -1)
.Value = .Value
End With
End With
End With
End Sub
Before fillBlanks procedure After fillBlanks procedure
Others have given working solutions, I'll just outline the problems with your code.
cellvar = ActiveCell assigns the value of the active cell to cellvar but cellvar won't change if ActiveCell changes so you'll just copy [SMITH, John] for all other people. You'd have to reassign cellvar.
If ActiveCell.Offset(1, 0) = "*" Then This checks if the cell contains an asterisk. Instead use Not ActiveCell.Offset(1, 0) = "", ActiveCell.Offset(1, 0) <> "", Not isEmpty(ActiveCell.Offset(1, 0)) or just Else (which would be the preferred version here since it doesn't require further calculations).
Edit: "*" Can be used as a wildcard with the Like operator as in If ActiveCell.Offset(1, 0) Like "*" Then but this would also be true for the empty string. To be sure that there is at least one sign you'd have to use "?*" instead. The question mark stands for exactly one character and the asterisk for 0 or more. To check if a cell is empty I would recommend one of the above ways though.
In you first sub this means that if the cell anything but "*", i will not be incremented and you end in an endless loop. In the second function, it means that the the active cell will not be changed and neither "" not "*" will be detected for the rest of the loop.
In the second sub, you don't need i=i+1, the for loop does that for you. This would mean that you increment i by 2 every iteration.
ActiveCell.Offset(1, 0).Select.Activate Here the "select" is too much
Here are the subs with minimal changes:
Sub rname()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
i = 0
While i < 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
ActiveCell.Offset(1, 0).Activate 'the code will run without this but need to iterations per row
i = i + 1
MsgBox "a " & i
Else
ActiveCell.Offset(1, 0).Activate
cellvar = ActiveCell 'reassign cellvar
i = i + 1
MsgBox "b " & i
End If
Wend
End Sub
second sub:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
cellvar = ActiveCell
'i = 1 'this is not necessary
For i = 1 To 50
If ActiveCell.Offset(1, 0) = "" Then
ActiveCell.Offset(1, 0) = cellvar
End If
If Not ActiveCell.Offset(1, 0) = "" Then 'if else endif would be nicer here
ActiveCell.Offset(1, 0).Activate 'remove "select"
cellvar = ActiveCell 'reassign cellvar
End If
'i = i + 1 'this is not necessary/wrong
Next i 'safer to include i
End Sub
Note that this is just to explain the problems with your code, I still recommend to use one of the other solutions here.
Try this:
Sub repeat_name()
Dim cellvar As String
Dim i As Integer
Dim ws As Worksheet
Set ws = Sheet1 'Change according to your sheet number
cellvar = ""
For i = 1 To 50
if Trim(ws.Range("A" & i )) <> "" then
cellvar = Trim(ws.Range("A" & i ))
Else
ws.Range("A" & i ) = cellvar
End if
Next i
End Sub
How about this:
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
try this:
Sub repeat_name()
Dim k As Integer
Dim i As Integer
i = 1
k = ActiveSheet.UsedRange.Rows.Count
While i <= k
With ActiveSheet
If .Range("A1").Value = "" Then
MsgBox "Error: First cell can not be empty."
Exit Sub
End If
If .Range("A" & i).Value = "" And .Range("B" & i).Value <> "" Then
.Range("A" & i).Value = .Range("A" & i - 1).Value
End If
End With
i = i + 1
Wend
End Sub
try this
Sub test()
lastrow = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 1) = "" Then
Cells(i, 1) = Cells(i - 1, 1)
End If
Next i
End Sub
I need help for VBA as I'm new to this programming language. Is it possible to have 2 different sets of codes in one sheet in the workbook?
I want to make the Excel sheet more interactive like clicking on certain cell then highlighting the entire row that the cell is selected. But the sheet that im trying to make it interactive has a set of codes already.
Here is the codes that I want to make the excel sheet interactive
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
initializeWorksheets
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
' Clear the color of all the cells
Cells.Interior.ColorIndex = 0
If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
With ActiveCell
' Highlight the row and column that contain the active cell, within the current region
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).Interior.ColorIndex = 6
End With
Next ws
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'filtering
Dim ws As Worksheet
ws.Activate
Dim ccolumn As Integer
Dim vvalue As String
ccolumn = ActiveCell.Column
vvalue = ActiveCell.Value
For Each ws In Worksheets
If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
With ActiveCell
Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + .CurrentRegion.Column - 1)).AutoFilter Field:=ccolumn, Criteria1:=vvalue
Cancel = True
End With
Next ws
End Sub
Here is the codes that it is used for the same sheet:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
initializeWorksheets
Application.ScreenUpdating = False
If (ActiveSheet.Name = "Student Viewer") Then
searchKey = Trim(Target.Range.Value)
If (Right(searchKey, 1) = ")") Then
searchKey = Right(searchKey, Len(searchKey) - InStrRev(searchKey, "(", -1))
searchKey = Left(searchKey, Len(searchKey) - 1)
End If
temp = 2
Do While (mainSheet.Range(findColumn(mainSheet, "IC Number") & temp) <> searchKey & "")
temp = temp + 1
If (temp > 65535) Then
MsgBox ("Error in Finding xxxx Details")
End
End If
Loop
viewerSheet.Unprotect
' Set details
For i = 2 To 10
viewerSheet.Range("C" & i) = mainSheet.Range(findColumn(mainSheet, Left(viewerSheet.Range("B" & i), Len(viewerSheet.Range("B" & i)) - 1)) & temp)
viewerSheet.Range("F" & i) = mainSheet.Range(findColumn(mainSheet, Left(viewerSheet.Range("E" & i), Len(viewerSheet.Range("E" & i)) - 1)) & temp)
Next i
For i = 2 To 3
viewerSheet.Range("I" & i) = mainSheet.Range(findColumn(mainSheet, Left(viewerSheet.Range("H" & i), Len(viewerSheet.Range("H" & i)) - 1)) & temp)
Next i
loadSummary
viewerSheet.Protect
ElseIf (ActiveSheet.Name = "xxxx Viewer") Then
searchKey = Trim(Target.Range.Value)
viewerSheet2.Unprotect
' Set details
temp = 2
Do While (DetailsSheet.Range(findColumn(DetailsSheet, "Policy Num") & temp) <> searchKey & "")
temp = temp + 1
If (temp > 65535) Then
MsgBox ("Error in Finding Details")
End
End If
Loop
For i = 2 To 11
viewerSheet2.Range("C" & i) = DetailsSheet.Range(findColumn(DetailsSheet, Left(viewerSheet2.Range("B" & i), Len(viewerSheet2.Range("B" & i)) - 1)) & temp)
Next i
For i = 2 To 6
viewerSheet2.Range("I" & i) = ValuesSheet.Range(findColumn(ValuesSheet, Left(viewerSheet2.Range("H" & i), Len(viewerSheet2.Range("H" & i)) - 1)) & temp)
Next i
For i = 7 To 12
viewerSheet2.Range("I" & i) = DetailsSheet.Range(findColumn(DetailsSheet, Left(viewerSheet2.Range("H" & i), Len(viewerSheet2.Range("H" & i)) - 1)) & temp)
Next i
viewerSheet2.Hyperlinks.Add Anchor:=Range("C2"), Address:="", SubAddress:="'Client Viewer'!A1"
loadDetail
viewerSheet2.Protect
End If
Application.ScreenUpdating = True
End Sub
As commented, you can try this approach:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
With Me ' Me refers to the worksheet where you put this code
.Cells.Interior.ColorIndex = -4142 ' xlNone
If Not CBool(-Target.Hyperlinks.Count) Then ' Check if there is hyperlink
Target.EntireRow.Interior.ColorIndex = 6 ' or you can use RGB(255, 255, 0)
Else
Target.Hyperlinks(1).Follow ' follow hyperlink if there is
CodeFromYourFollowHyperlinkEvent ' call a routine
End If
End With
moveon:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume moveon
End Sub
As you can see above, CodeFromYourFollowHyperlinkEvent should be a sub that contains what you want done in your FollowHyperlink event as shown below.
Private Sub CodeFromYourFollowHyperlinkEvent()
' Put your code in FollowHyperlink here
initializeWorksheets
Application.ScreenUpdating = False
If (ActiveSheet.Name = "Student Viewer") Then
.
.
.
End Sub
Now take note that you need to exercise explicitly working on your objects.
To know more about that, check this cool post out.