Search, find, copy and paste macro debug VBA - vba

I am pretty new to VBA and I am having a bit of trouble writing a macro.
I want to search a value in a cell, on a column, that is on another worksheet and if it finds it, copy and paste the whole row where it is to another worksheet.
I pretty much have that one sorted but only doing 1 row. What I can't get to work is that after the first value has been read in "sheetTarget" say in cell T4, found in "sheetToSearch" say in A230 and pasted in row 1 in "sheetPaste" move and read the next cell T5 in "sheetTarget" and then keep repeating the process eg. find value of T5 on A350 and paste in row 2, T6 in A20 and paste on row 3, etc..
Sub copyE()
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
LCopyToRow = 1
Dim sheetPaste As String: sheetPaste = "Sheet11"
Dim sheetTarget As String: sheetTarget = "Sheet8"
Dim sheetToSearch As String: sheetToSearch = "Sheet1"
Dim x As String
Dim columnValue As String: columnValue = "T"
Dim rowValue As Integer: rowValue = 4
Dim LTargetRow As Long
Dim maxRowToTarget As Long: maxRowToTarget = 1000
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 5
Dim LSearchRow As Long
Dim maxRowToSearch As Long: maxRowToSearch = 1000
For LTargetRow = rowValue To Sheets(sheetTarget).Rows.Count
Sheets(sheetTarget).Range(columValue & CStr(LTargetRow)).Value = x
For LSearchRow = iniRowToSearch To Sheets(sheetToSearch).Rows.Count
If Sheets(sheetToSearch).Range(columnToSearch & CStr(LSearchRow)).Value = x Then
Sheets(sheetToSearch).Rows(LSearchRow).copy
Sheets(sheetPaste).Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues
LCopyToRow = LCopyToRow + 1
End If
If (LSearchRow >= maxRowToSearch) Then
Exit For
End If
Next LSearchRow
If (LTargetRow >= maxRowToTarget) Then
Exit For
End If
Next LTargetRow
Application.CutCopyMode = False
Range("A3").Select
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
I will greatly appreciate any help.

This works for me and I believe it is what you are asking for.
Sub test()
Dim sheetPaste As Worksheet
Dim sheetTarget As Worksheet
Dim sheetToSearch As Worksheet
Dim x As String
Dim columnValue As String: columnValue = "T"
Dim rowValue As Integer: rowValue = 4
Dim LTargetRow As Long
Dim maxRowToTarget As Long: maxRowToTarget = 1000
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 5
Dim LSearchRow As Long
Dim maxRowToSearch As Long: maxRowToSearch = 1000
LCopyToRow = 1
Set sheetPaste = ThisWorkbook.Worksheets("Sheet11")
Set sheetTarget = ThisWorkbook.Worksheets("Sheet8")
Set sheetToSearch = ThisWorkbook.Worksheets("Sheet1")
'MsgBox sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row
'finds the last row with a value in it in column T of sheetTarget
For LTargetRow = rowValue To sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row
'targetCell = columValue & CStr(LTargetRow)
'must set x = , not the value in the column = to x (which is not initialize to it is "")
If sheetTarget.Range(columnValue & CStr(LTargetRow)).Text <> "" Then
x = sheetTarget.Range(columnValue & CStr(LTargetRow)).Text
'finds the last row with a value in it in column A of sheetToSearch
For LSearchRow = iniRowToSearch To sheetToSearch.Cells(Rows.Count, 1).End(xlUp).Row
If sheetToSearch.Range(columnToSearch & CStr(LSearchRow)).Value = x Then
sheetToSearch.Rows(LSearchRow).Copy
sheetPaste.Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues
LCopyToRow = LCopyToRow + 1
Exit For
End If
'dont need this anymore now that we know that last row with data in it.
' If (LSearchRow >= maxRowToSearch) Then
' Exit For
' End If
Next LSearchRow
End If
'If (LTargetRow >= maxRowToTarget) Then
' Exit For
'End If
Next LTargetRow
'Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row
End Sub
Some of the variables are not used anymore and if you have any questions feel free to ask.

Related

Excel: VBA to delete group of rows

I have an excel file with one column with data. Something like:
21/07/2017
DEF
GHI
Field 7
SOMETHING HERE
MORE TEXT
21/07/2017
DEF
GHI
Field 7
This is repeated a few thousand times. What I am looking for is all rows between and including 21/07/2017 and Field 7 to be deleted and for the rows to be moved up.
I've tried a few things but now back to a blank canvas! Any hints?
Thanks
CODE I TRIED
I get an Overflow error
Sub deleteRows()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 1
Application.DisplayAlerts = False
Set sh = ActiveSheet
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "21/07/2017" Then
a = RowCount
End If
If sh.Cells(rw.Row, 1).Value = "Field 7" Then
b = RowCount
Rows(a & ":" & b).Delete
End If
RowCount = RowCount + 1
Next rw
End Sub
This will only loop as many times as the pair exists and delete each block as a whole.
The loop ends the first time that both are not found in the remaining values.
Sub myDelete()
Dim str1 As string
Dim str2 As String
Dim rng As Range
Dim ws As Worksheet
Dim i As Long
Dim j As Long
str1 = "21/07/2017"
str2 = "Field 7"
Set ws = Worksheets("Sheet18") 'change to your worksheet
Set rng = ws.Range("A:A")
Do
i = 0: j = 0
On Error Resume Next
i = Application.WorksheetFunction.Match(str1, rng, 0)
j = Application.WorksheetFunction.Match(str2, rng, 0)
On Error GoTo 0
If i > 0 And j > 0 Then
ws.Rows(i & ":" & j).Delete
End If
Loop Until i = 0 Or j = 0
End Sub
If your date is a true date then change str1 to Double:
Dim str1 As Double
and then assign it as such:
str1 = CDbl(DateSerial(2017, 7, 21))

Copy/Paste data that is not the entre row

I cannot paste anywhere besides column "A" I have tried changing the column letter, but I get an error code saying the "copy/paste cell are not the same size".
Sub HEA_Filter_Names()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
strArray = Array("ack-")
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = Sheets("Real Alarms")
For I = 1 To NoRows
Set rngCells = wsSource.Range("B" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub
You cannot paste an EntireRow starting anywhere else than column A.
You can try this instead:
Intersect(rngCells.EntireRow, rngCells.Parent.UsedRange).Copy wsDest.Range("F" & DestNoRows)

Error when matching records

Problem :
Code returns 0 matches.
Code :
Sub searchNames()
Dim loc As String
Call location(loc)
Dim loadWb As Workbook
Dim loadWs As Worksheet
' ~~ Load file location
Set loadWb = Workbooks.Open(loc)
Set loadWs = loadWb.Sheets("Sheet1")
' ~~ Init rows in loaded excel
Dim lrow As Long
With loadWs
' ~~ Set range for lookup value
lrow = .Range("G" & .rows.Count).End(xlUp).Row
End With
' ~~ Loop to remove trailing spaces
Dim TrimCounter As String
Dim NewString As String
For ind = 2 To lrow
' ~~ Set rows for trim
TrimCounter = loadWs.Range("G" & ind).Value
NewString = Trim(TrimCounter)
' ~ Write trimmed values
loadWs.Range("G" & ind).Value = NewString
Next ind
' ~~ Set output worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("ALL BRANDS")
Dim lrowWs As Long
With ws
lrowWs = .Range("D" & .rows.Count).End(xlUp).Row
End With
Dim counter As Long
Dim rows As Long
Dim nameCounter As String
counter = 0
' ~~ Get controlPointNumber in ALL BRANDS
For ind = 2 To lrowWs
' ~~ Set controlPointNumber
nameCounter = ws.Range("D" & ind).Value
' ~~ Start with row 2 in loaded Excel to omit header
For ind2 = 2 To lrow
' ~~ Check if the name matches in ALL BRANDS
If loadWs.Range("G" & ind2).Value = nameCounter Then
counter = counter + 1
End If
Next ind2
' ~~ Write the value in Worksheet 'ALL BRANDS' equal to the results
ws.Range("L" & ind).Value = counter
' ~~ Init counter to 0 and check other controlPointNumber
counter = 0
rows = rows + 1
Next ind
' ~~ Close workbook ~ Byeee
loadWb.Close False
MsgBox "Scan finished! Scanned " & rows & " rows"
End Sub
Screenshots :
Am I missing something? Any ideas?
EDIT:
Problem located. There are spaces in the values in COLUMN G
Change the part of the code like this:
For ind = 2 To lrowWs
Debug.Print lrowWs
nameCounter = ws.Range("D" & ind).value
Debug.Print nameCounter
For ind2 = 2 To lrow
If loadWs.Range("G" & ind2).value = nameCounter Then
Debug.Print loadWs.Range("G" & ind2).value
counter = counter + 1
End If
Next ind2
ws.Range("L" & ind).value = counter
Stop
counter = 0
rows = rows + 1
Next ind
Then, when you reach the stop, you should have 3 different values in the immediate window. Take a good look at them, analyze them and repair the whole code correspondingly.
Edit:
Probably the error comes from the idea, that you can use something like this:
Dim rows As Long
Thus, VBA does not know what you mean, when you say rows.Count. Long story short, change the Dim rows as Long to Dim lngRows as long and fix correspondingly everywhere.
I always worked with the .find Method. For me it's easier and if you combined it with a dictionary you can do the whole range and can be sure that no Value will be missing. The code will take the range with values from column A and will count how often the value appears in the range. Hope the code can help you.
Sub Makro1()
'Excel objects.
Dim wb As Workbook
Dim ws As Worksheet
Dim rngLockin As Range
Dim rngFind As Range
Dim idx As Integer
Dim idxRow As Integer
idxRow = 2
Dim strAddress As String
'Initialize the Excel objects.
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tabelle1")
Set dicSearch = CreateObject("Scripting.Dictionary")
LastRow = ws.UsedRange.Rows.Count
Set rngLockin = ws.Range("A2:A22").SpecialCells(xlCellTypeConstants)
For Each rngcell In rngLockin
'I Value is not in dic, insert it and start counting
If Not dicSearch.Exists(rngcell.Value) Then
dicSearch.Add rngcell.Value, ""
'Search the four columns for any constants.
'Retrieve all columns that contain X. If there is at least one, begin the DO/WHILE loop.
idx = 0
With rngLockin
Set rngFind = .Find(What:=rngcell.Value, LookIn:=xlValues)
If Not rngFind Is Nothing Then
strAddress = rngFind.Address
idx = idx + 1
rngFind.Select
'Unhide the column, and then find the next X.
Do
rngFind.EntireColumn.Hidden = False
Set rngFind = .FindNext(rngFind)
rngFind.Select
If Not rngFind Is Nothing And rngFind.Address <> strAddress Then idx = idx + 1
Loop While Not rngFind Is Nothing And rngFind.Address <> strAddress
End If
End With
Cells(idxRow, 3) = rngcell.Value
Cells(idxRow, 4).Value = idx
idxRow = idxRow + 1
End If
Next
End Sub
Fell free to ask if you have a question.

Excel crashes without errors or indication why when running simple VBA code?

Excel has started crashing without any explanation and the code has worked previously so I am not exactly sure why it is constantly crashing now. It isn't even that much code or very complex. I am simply adding new values to a table in two separate worksheets. Any help would be greatly appreciated!
Sheet 1:
Option Explicit
Private Sub CommandButton1_Click()
Dim nameStr As String
nameStr = TextBox1.Value
Dim costInt As Integer
costInt = TextBox2.Value
Dim newRateValues(8)
newRateValues(0) = nameStr
newRateValues(1) = costInt
newRateValues(2) = costInt
newRateValues(3) = costInt
newRateValues(4) = costInt
newRateValues(5) = costInt
newRateValues(6) = costInt
newRateValues(7) = costInt
newRateValues(8) = costInt
AddDataRow "ratesTable", newRateValues
AddDataRow2 "tableResources"
End Sub
Module:
Option Explicit
Sub AddDataRow(tableName As String, values() As Variant)
Dim sheet As Worksheet
Dim table As ListObject
Dim col As Integer
Dim lastRow As Range
Set sheet = ActiveWorkbook.Worksheets("Sheet1")
Set table = sheet.ListObjects.Item(tableName)
'First check if the last row is empty; if not, add a row
If table.ListRows.count > 0 Then
Set lastRow = table.ListRows(table.ListRows.count).Range
For col = 1 To lastRow.Columns.count
If Trim(CStr(lastRow.Cells(1, col).Value)) <> "" Then
table.ListRows.Add
Exit For
End If
Next col
Else
table.ListRows.Add
End If
'Iterate through the last row and populate it with the entries from values()
Set lastRow = table.ListRows(table.ListRows.count).Range
For col = 1 To lastRow.Columns.count
If col <= UBound(values) + 1 Then lastRow.Cells(1, col) = values(col - 1)
Next col
End Sub
Sub AddDataRow2(tableName As String)
Dim sheet As Worksheet
Dim table As ListObject
Dim col As Integer
Dim lastRow As Range
Dim newRate As Integer
Set sheet = ActiveWorkbook.Worksheets("Sheet2")
Set table = sheet.ListObjects.Item(tableName)
newRate = ActiveSheet.TextBox1.Text
'First check if the last row is empty; if not, add a row
If table.ListRows.count > 0 Then
Set lastRow = table.ListRows(table.ListRows.count).Range
For col = 1 To lastRow.Columns.count
If Trim(CStr(lastRow.Cells(1, col).Value)) <> "" Then
table.ListRows.Add
Exit For
End If
Next col
Else
table.ListRows.Add
End If
'Iterate through the last row and populate it with the entries from values()
Set lastRow = table.ListRows(table.ListRows.count).Range
lastRow.Cells(1, 2) = newRate
End Sub

Using VBA to copy data from one worksheet into another worksheet

I have a slight problem in Excel. I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F. I would like this data to be copied across to a new worksheet in the same workbook. Any ideas how I could accomplish this? You don't have to provide any code but a nudge in the right direction would be great.
E.g. on the Emails sheet
becomes this on a new sheet
In case anyone needs help, this is the solution:
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
You didn't ask a question. Basically what you would do is
loop through the values in column F
for each value, get the value in column C
loop through all braced values in column C
let braceValue = parse column C searching for {value}
create a row in new worksheet with column F value, braceValue