I am having trouble making a string variable equal to the cell in a worksheet since I get a type mismatch. I would also like to make a single string variable (SheetString) equal to all worksheet content. A portion of my code is below:
Range("A1").Select
Set sht = ThisWorkbook.Worksheets("Sheet3")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1:A" & LastRow).SpecialCells(xlCellTypeBlanks)
rng.EntireRow.Delete
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'MsgBox (Continue)
Set rng = Range("A1:A" & LastRow)
'For x = 1 To LastRow
'RowString = cell(x, 1).Value
'if instr(,RowString,("Sheet1").
SheetString = Range("a1:a" & LastRow).Value
MsgBox (Continue)
IE.Quit
Thanks
you can't assign a string like this, if you want to asign the whole Range in Column A, you nned a loop, like this:
For i = 1 To LastRow
SheetString = SheetString & ";" & Range("A" & i).Value
Next i
See this example
Sub Sample()
Dim SheetString As String
LastRow = 12 '<~~ Example
SheetString = range("a1:a" & LastRow).Value
End Sub
You can't do this. You can store the entire column in an array though. For that you have to declare SheetString as Variant as shown below else you will get the Type Mismatch error as you are currently getting
Sub Sample()
Dim SheetString As Variant
LastRow = 12 '<~~ Example
SheetString = range("a1:a" & LastRow).Value
End Sub
This will create an array which you can loop to access
For i = LBound(SheetString) To UBound(SheetString)
Debug.Print SheetString(i, 1)
Next i
Related
I am trying to do the macro which can do autofilter and copy the visible row , then paste them into the new sheet by using VBA. my code as below:
Option Explicit
Sub lab()
Dim ws As Worksheet
Dim sh1 As Worksheet
Dim mycoll As Collection
Set mycoll = New Collection
Set sh1 = ThisWorkbook.Sheets(1)
Dim rng As Range
Dim c As Range
Dim lastrow As Long
lastrow = Range("C" & Rows.Count).End(xlUp).Row
On Error Resume Next
Set rng = sh1.Range("B4:F" & lastrow)
With rng
.AutoFilter field:=2, Criteria1:=sh1.Range("I1"), Criteria2:=sh1.Range("I2"), Operator:=xlOr
.AutoFilter field:=3, Criteria1:=sh1.Range("K1"), Criteria2:=sh1.Range("K2"), Operator:=xlOr
.AutoFilter field:=4, Criteria1:=sh1.Range("M1"), Criteria2:=sh1.Range("M2"), Operator:=xlOr
End With
Set ws = Worksheets.Add
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
rng.SpecialCells(xlCellTypeVisible).Copy ws.Range("A1")
rng.AutoFilter
sh1.Activate
End Sub
my problem is the code only work correctly for the first new sheet. then it always create the sheet with the same content. I tried to find the root issue , could you please help assist on this ?
When there is a problem with your code, you never use On Error Resume Next! It only does not let VBA 'telling' you what problem the code has...
If your code names the newly created sheet using:
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
second time, if the concatenation of the two cells value is the same, VBA cannot name a sheet with the same name like an existing one. The raised error should have a clear description but your code jumps over it, because of On error Resume Next.
If you really need/want to use a similar sheet name, try placing a sufix. For doing that, you can use the next function:
Function shName(strName As String) As String
Dim ws As Worksheet, arrSh, arrN, maxN As Long, k As Long, El
ReDim arrSh(ActiveWorkbook.Sheets.count - 1)
For Each ws In ActiveWorkbook.Sheets
If ws.Name = strName Then
shName = strName & "_" & 1
Exit Function
End If
If InStr(ws.Name, strName & "_") > 0 Then arrSh(k) = ws.Name: k = k + 1
Next
If k = 0 Then shName = strName: Exit Function 'if no such a name exists
ReDim Preserve arrSh(k - 1)
'determine the bigger suffix:
For Each El In arrSh
arrN = Split(El, "_")
If CLng(arrN(UBound(arrN))) > maxN Then maxN = CLng(arrN(UBound(arrN)))
Next
shName = strName & "_" & maxN + 1
End Function
It should be called from your existing code replacing the line
ws.Name = sh1.Range("I1").Value & "-" & sh1.Range("I2").Value
with
ws.Name = shName(sh1.Range("I1").Value & "-" & sh1.Range("I2").Value)
My code below is supposed to filter data in the wsData and then copy it into the wsTest worksheet after each other in column A. The code works except that it copies the values over each on the destination sheet rather then after each other. Any idea why?
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With ActiveSheet
.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy Destination:=wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp)
.AutoFilterMode = False
End With
Next k
End Sub
As first point: if using a range with AutoFilter the copy will always exclude the hidden cells
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
is all you need here.
Regarding your error: On Error Resume Next hides the error of i = wsTest.Range("A" & Rows.Count).End(xlUp) which would return a range rather than a numerical value.
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
is your friend here :)
Everything together should look something like that:
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With wsData
.AutoFilterMode = False
With .Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
.AutoFilterMode = False
End With
Next k
End Sub
EDIT: For excluding headers just change:
.Copy wsTest.Range("A" & i)
to:
If i = 1 Then .Copy wsTest.Range("A" & i) Else .Offset(1, 0).Copy wsTest.Range("A" & i)
and if you do not want any headers at all then directly use:
.Offset(1, 0).Copy wsTest.Range("A" & i)
But I havent tested it. Just tell me if you get any problems ;)
I have two sheets. I want to check the value in one column against the value in the same column in the second sheet. If they match, then I want to migrate the string data from the Notes column to the new sheet. (essentially I'm seeing if last week's ticket numbers are still valid this week, and carrying over the notes from last week).
I am trying to do this with the following code (using columns Z for the data, BE for the notes):
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Dim partNo2 As Range
Dim partNo1 As Range
Dim partNo3 As Range
For Each partNo2 In ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo3 In ws1.Range("BE1:BE" & ws2.Range("BE" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("BE" & partNo1.Row) = partNo3
End If
Next
Next
Next
'now if no match was found then put NO MATCH in cell
For Each partNo1 In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmpty(partNo1) Then partNo1 = ""
Next
End Sub
Untested:
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim c As Range, f As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set rng1 = ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
Set rng2 = ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each c In rng1.Cells
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
f.EntireRow.Cells(, "BE").Value = c.EntireRow.Cells(, "BE").Value
End If
Next c
'now if no match was found then put NO MATCH in cell
For Each c In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If Len(c.Value) = 0 Then c.Value = "NO MATCH"
Next
End Sub
This accomplishes the same result (maybe with the exception of the columns E & F at the bottom with NO MATCH). It's just a different way of going about it. Instead of using ranges, I'm just looking at each cell and comparing it directly.
TESTED:
Sub NoteMatch()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("Z" & Rows.Count).End(xlUp).row
lastRow2 = Sheets("Sheet2").Range("Z" & Rows.Count).End(xlUp).row
For sRow = 2 To lastRow1
tempVal = Sheets("Sheet1").Cells(sRow, "Z").Text
For tRow = 2 To lastRow2
If Sheets("Sheet2").Cells(tRow, "Z") = tempVal Then
Sheets("Sheet2").Cells(tRow, "BE") = Sheets("Sheet1").Cells(sRow, "BE")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet2").Cells(lRow, "Z").Text
For sRow = 2 To lastRow1
If Sheets("Sheet1").Cells(sRow, "Z") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
End If
Next lRow
End Sub
I currently have a script (See Below) that adds the contents of every cell in the used rows to another cell in a different worksheet. However, this works for the first 3 cells but will not work for the last 2 for some reason.
Sub Ready_For_Infra()
Dim i As Integer
Dim k As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row Step 1
For k = 1 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
With Worksheets("InfraData")
If ws2.Cells(k, i).Value <> "" Then
ws1.Range("A" & i).Value = ws1.Range("A" & i).Value & ws2.Cells(i, k).Value & Chr(10)
End If
End With
Next k
Next i
MsgBox "Done"
End Sub
This is the data in ws2 (ActionPlan) just in case it helps:
To clarify, it doesn't appear to be appending Cells D2:F3 to the cells I have asked it to. Is anyone able to advise why this might be the case?
Try this code:
Sub Ready_For_Infra()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range
Dim i As Long, lastrow As Long, lastcol As Long
Dim str1 As String
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
With ws2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To lastrow
str1 = ""
For Each cell In .Range(.Cells(i, 1), .Cells(i, lastcol))
If cell.Value <> "" Then str1 = str1 & cell.Value & Chr(10)
Next cell
ws1.Range("A" & i).Value = str1
Next i
End With
MsgBox "Done"
End Sub
Notes:
using For each loop is slightly faster then For k=1 To lastcol
using temporary string variable str1 makes your code faster as well, because in that case you writes result value in ws1.Range("A" & i) cell only once (working with operating memory is always faster than writing subresult in cell for each iteration).
I can't seem to get my second for loop right. I'm looking for the cell with value 'Persoonlijke prijslijst'. Once I have this cell I need to go up two and delete 8 down. When I debug, it says temp = 0 so I presume it's in my second for loop.
Dim i As Integer
For i = 1 To 800
Range("C" & i).Select
If Range("C" & i).Value = "Persoonlijke prijslijst" Then
Dim temp As Integer
For temp = i - 2 To temp + 8
Range("C" & temp).EntireRow.Delete Shift:=xlToLeft
Next temp
End If
Next i
Another way without looping 800 times:
Sub testing()
Dim rng As Range
Dim fAddress As String
Dim rngRows As Range
With Sheet1.Range("C1:C800")
Set rng = .Find("Persoonlijke prijslijst")
If Not rng Is Nothing Then
fAddress = rng.Address
Do
If rngRows Is Nothing Then
Set rngRows = rows(rng.Row - 2 & ":" & rng.Row + 5)
Else
Set rngRows = Union(rngRows, rows(rng.Row - 2 & ":" & rng.Row + 5))
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> fAddress
End If
End With
rngRows.EntireRow.Delete
End Sub
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim StrSearch As String
Dim i As Long
'~~> Change this to the relevant sheet name
Set ws = Sheets("Sheet1")
StrSearch = "Persoonlijke prijslijst"
With ws
For i = 800 To 1 Step -1
If .Range("C" & i).Value = StrSearch Then
.Rows(i - 2 & ":" & i + 5).Delete
End If
Next i
End With
End Sub