Just started using VBA and I'm basically looking to check if an item in a column is text and then copy it to another sheet in a row. I get stopped at the first line of the IF statement with
Error 424 - Object Required
Have looked at a few of these questions and websites and can't seem to figure out where I've gone wrong.
Thanks very much.
Sub Copier()
Dim i As Integer
Dim j As Integer
j = 1
For i = 1 To 100
If IsText.Sheets("Strategies").Cells(i, 6) = True Then
Sheets("Strategies").Select
Cells(i, 6).Select
Selection.Copy
Sheets("Stats").Select
Cells(2, j).Select
Sheets("Stats").Paste
j = j + 1
End If
Next i
End Sub
IsText is a method of the WorksheetFunction class.
You have got your syntax wrong, the correction would be:
If WorksheetFunction.IsText(Sheets("Strategies").Cells(i, 6)) = True Then
The IsText() method should not be called with a ., but rather using (), like this:
For i = 1 To 100
s = Sheets("Strategies").Cells(i, 6).Value
If Application.WorksheetFunction.IsText(s)Then
Sheets("Strategies").Select
Cells(i, 6).Select
Selection.Copy
Sheets("Stats").Select
Cells(2, j).Select
Sheets("Stats").Paste
j = j + 1
End If
Next i
Using Variant is so fast.
Sub test()
Dim i As Integer
Dim j As Integer
Dim Wf As WorksheetFunction
Dim fromWs As Worksheet, ToWs As Worksheet
Dim vDB, vR()
Set fromWs = Sheets("Strategies")
Set ToWs = Sheets("Stats")
Set Wf = WorksheetFunction
vDB = fromWs.Range("f1").Resize(100)
For i = 1 To UBound(vDB, 1)
If Wf.IsText(vDB(i, 1)) Then
j = j + 1
ReDim Preserve vR(1 To j)
vR(j) = vDB(i, 1)
End If
Next i
If j > 0 Then
ToWs.Range("a2").Resize(1, j) = vR
End If
End Sub
You could tidy the whole thing up as follows:
Dim i As Integer, j As Integer
Dim sourcesheet As Worksheet, targetsheet As Worksheet
j = 1
Set sourcesheet = Sheets("Strategies")
Set targetsheet = Sheets("Stats")
With sourcesheet
For i = 1 To 100
s = .Cells(i, 6).Value
If Application.WorksheetFunction.IsText(s) Then
.Cells(i, 6).Copy targetsheet.Cells(2, j)
j = j + 1
End If
Next i
End With
Related
I wrote a little code to mark the differences in two different tables.
When I run the code, there are many right "hits", but for some reason, sometimes the exact same value is marked as different. This mostly happened with numbers or if the alignment is not the same.
To get rid of the alignment- and formatting- problem I wrote/found the following Code:
Sub makeBeautiful()
Dim n As Integer
Dim m As Integer
Dim wks As Worksheet
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
For j = 1 To m
For i = 1 To n
If sht.Cells(i, j).Value = "null" Then
sht.Cells(i, j).Value = " "
End If
Next i
Next j
For Each wks In Worksheets
wks.Cells.VerticalAlignment = xlTop
wks.Cells.HorizontalAlignment = xlLeft
Next wks
sht.Cells.NumberFormat = "General"
sht2.Cells.NumberFormat = "General"
End Sub
As far as I can tell, this works just fine.
To mark the differences, I have the following Code:
Sub changeFinder()
Dim n As Integer
Dim m As Integer
Dim p As Integer
Dim o As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim Result As String
Dim item1 As String
Dim item2 As String
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("bank-accountsNew")
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("bank-accountsOld")
n = sht.UsedRange.Rows.Count
m = sht.UsedRange.Columns.Count
k = sht2.UsedRange.Rows.Count
l = sht2.UsedRange.Rows.Count
For j = 1 To m
sht.Columns(j + 1).Insert
sht.Columns(j + 1).Insert
For i = 2 To n
sht.Cells(i, j + 1).Value = Application.VLookup(sht.Cells(i, 1), sht2.Columns(1).Resize(, j), j, False)
Next i
For i = 2 To n
item1 = sht.Cells(i, j).Text
item2 = sht.Cells(i, j + 1).Text
Result = StrComp(item1, item2)
sht.Cells(i, j + 2) = Result
Next i
For i = 2 To n
If sht.Cells(i, j + 2) = 1 Then
sht.Cells(i, j).Interior.Color = vbRed
End If
Next i
sht.Columns(j + 1).Delete
sht.Columns(j + 1).Delete
Next j
End Sub
My idea was to create two new column next to every column I want to compare. Fill these two new column with the fitting value and a number to check either these values are the same or not. If not, the original value should be marked in red.
I have in both table almost the same bank accounts numbers as column 3.
Some of them are marked as different and some them are not marked as different, but in only case they are not the same. So, my code does not work properly.
As far as I can tell, every value is equally aligned and equally formatted, so I don´t know what could cause Excel to think that the same numbers are different. :/
Table B is created by a json.file. Table A ist created by PowerQuery with two tables, which I have from a json.file.
I hope someone can help me here a litle bit.
Sincerely,
Julian
Rather than repeated VLookups consider using a Dictionary Object.
Option Explicit
Sub changeFinder()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim lastrow As Long, r As Long, r2 As Long
Dim lastcol As Long, c As Long
With ThisWorkbook
Set sht1 = .Sheets("bank-accountsNew")
Set sht2 = .Sheets("bank-accountsOld")
End With
' build look up to sheet2
Dim dict As Object, id As String, n As Long
Set dict = CreateObject("Scripting.Dictionary")
With sht2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
If dict.exists(id) Then
MsgBox "Error - duplicate id " & id, vbCritical, sht2.Name & " row " & r
Exit Sub
ElseIf Len(id) > 0 Then
dict.Add id, r
End If
Next
End With
' compare with sheet 1
With sht1
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .UsedRange
lastcol = .Columns.Count
.Interior.Color = xlNone 'clear sheet
End With
' scan down sheet
For r = 2 To lastrow
id = Trim(.Cells(r, 1))
' check exists on sheet2
If Not dict.exists(id) Then
.Rows(r).Interior.Color = RGB(128, 255, 128)
n = n + 1
Else
r2 = dict(id) ' sheet 2 row
' scan across columns
For c = 2 To lastcol
If Trim(.Cells(r, c)) <> Trim(sht2.Cells(r2, c)) Then
.Cells(r, c).Interior.Color = RGB(255, 128, 0)
n = n + 1
'Debug.Print .Cells(r, c), sht2.Cells(r2, c)
End If
Next
End If
Next
End With
' result
If n > 0 Then
MsgBox n & " differences found", vbExclamation
Else
MsgBox "No differences found", vbInformation
End If
End Sub
I have a code when runs perfectly by hitting F8 (running steps by steps). However, it doesn't work when hitting F5(running it). I guess it's because my code is kind of in loop but I couldn't figure out what's wrong.
Sub BLKReport()
Dim IRow As Long
Dim lcntr As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim b As Long
Dim r As String
Dim i As Long
Set ws = ThisWorkbook.Worksheets("CSV File")
Set ws1 = ThisWorkbook.Worksheets("Destination")
lrow = Range("A2").End(xlDown).Row
For lcntr = lrow To 1 Step -1
If ws.Cells(lcntr, 9).Value = "25" Then
r = ws.Cells(lcntr, 2).Value
For i = lcntr To 1 Step -1
If ws.Cells(i, 2).Value = r Then
ws.Rows(i).Copy
ws1.Activate
b = i
ws1.Cells(b - 1, 1).Select
ActiveSheet.Paste
ws.Activate
ElseIf ws.Cells(i + 1, 1).Value <> r Then
End If
Next i
End If
Application.CutCopyMode = False
ws.Select
Next
End Sub
I have multiple columns in an excel sheet...say A1:D10.
I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.
Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this
Sub Demo1()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
Dim rng As Range, arr As Range
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
On Error Resume Next
Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
For Each arr In rng.Areas
arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
Next
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this
Sub Demo()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
If IsEmpty(.Cells(LastRow, TestColumn)) Then
.Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
End If
For i = LastRow - 1 To FirstRow Step -1
If IsEmpty(.Cells(i, TestColumn)) Then
.Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Using Variant Array Method
Sub test2()
Dim rngDB As Range, vDB As Variant
Dim i As Integer, j As Integer, n As Integer
Dim k As Integer
Set rngDB = Range("a1:d10")
vDB = rngDB
n = UBound(vDB, 1)
For i = 1 To n
If IsEmpty(vDB(i, 3)) Then
For j = 1 To 4
If j <> 3 Then
vDB(i, j) = Empty
End If
Next j
End If
Next i
For j = 1 To 4
If j <> 3 Then
For i = 1 To n - 1
For k = i To n - 1
If vDB(k, j) = Empty Then
vDB(k, j) = vDB(k + 1, j)
vDB(k + 1, j) = Empty
End If
Next k
Next i
End If
Next j
rngDB = vDB
End Sub
The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.
Sub deleteEmptyRow()
Dim i As Integer
For i = 1 To 10
If Cells(i, 3) = "" Then
Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
End If
Next i
End Sub
Here the code:
Sub deleterow2()
Dim a As Integer
Dim n As Integer
Dim c As Integer
LastRow = Range("F" & Rows.Count).End(xlUp).Row
For n = 0 To LastRow
a = 1
c = 0
Do Until c = 1
Cells(n + a, 6).Select
If Selection.value = Cells(n, 6) And Selection.value > 30 Then
Selection.EntireRow.Delete
Else
c = 1
End If
a = a + 1
Loop
Next n
End Sub
What s wrong with that?
Please see below corrected code... instead of starting n at 0, start with a at 0. Plus, avoid using .Select everything... and you should try to declare your ranges fully:
Sub deleterow222()
Dim lastRow As Long, R As Long
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Dim idColumn as Long: idColumn = 6
Dim diffColumn as Long: diffColumn = 19
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
For R = lastRow To 2 Step -1
With ws
If .Cells(R, idColumn) = .Cells(R - 1, idColumn) And .Cells(R, diffColumn) > 30 Then
.Cells(R, idColumn).EntireRow.Delete
End If
End With
Next R
End Sub
Some Tips:
You could not use n = 0 because you will create an error. Rows start from 1.
When you loop in order to delete you start from the end.
For n = LastRow To 1 Step -1
If there are a lot of lines and you will use For Loop declare you variable As Long.
If you have a lot of rows it s better to use an Array.
Try to avoid .Select by creating a With Statement with the sheet name
With ThisWorkbook.Worksheets("Sheet1") and refer to cell using .Cells(n + A, 6).Value
Do Until should start also from high to low due to the fact that you go from bottom to top.
enter image description here
Sub deleterow2()
Dim lastRow As Long, R As Long
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
For R = lastRow To 2 Step -1
With ws
If .Cells(R, 6).value = .Cells(R - 1, 6) And .Cells(R, 19).value > 30 Then
.Cells(R, 6).EntireRow.Delete
End If
End With
Next R
End Sub
The following code converts a table of values to a single column.
The problem is, with my table the number of rows in each column decreases by one for each successive column. Similar to the table shown below.
I am VERY new to writing code and only know the very basics. I copied a script found online to convert a range of values to a single column. The portion of code that I wrote to delete any blank cells is slowing the code tremendously. To convert around 250,000 points to a column is taking roughly 9 hours. I am hoping to reduce the processing time as this is a script I expect to use regularly.
Sub CombineColumns()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim rng As Range
Dim iCol As Long
Dim lastCell As Long
Dim K As Long
K = 484
'set K equal to the number of data points that created the range
Set rng = ActiveCell.CurrentRegion
lastCell = rng.Columns(1).Rows.count + 1
For iCol = 2 To rng.Columns.count
Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.count, iCol)).Cut
ActiveSheet.Paste Destination:=Cells(lastCell, 1)
lastCell = lastCell + rng.Columns(iCol).Rows.count
Next iCol
Dim z As Long
Dim m As Long
z = K ^ 2
For Row = z To 1 Step -1
If Cells(Row, 1) = 0 Then
Range("A" & Row).Delete Shift:=xlUp
Application.StatusBar = "Progress: " & Row & " of z: " & Format((z - Row) / z, "Percent")
DoEvents
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sample Table Structure
Because I gave errant information on where this should be posted.
The following code will do what you want nearly instantly.
I used arrays to limit the number of interactions with the worksheet.
Sub foo5()
Dim ws As Worksheet
Dim rng() As Variant
Dim oarr() As Variant
Dim i&, j&, k&
Set ws = ThisWorkbook.Worksheets("Sheet19") 'Change to your sheet
With ws
rng = .Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Value
ReDim oarr(1 To Application.WorksheetFunction.CountA(rng), 1 To 1)
k = 1
For i = LBound(rng, 1) To UBound(rng, 1)
For j = LBound(rng, 2) To UBound(rng, 2)
If rng(i, j) <> "" Then
oarr(k, 1) = rng(i, j)
k = k + 1
End If
Next j
Next i
.Range("A1", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft))).Clear
.Range("A1").Resize(UBound(oarr), 1).Value = oarr
End With
End Sub