Create macro to move data in a column UP? - vba

I have an excel sheet of which the data was jumbled: for example, the data that should have been in Columns AB and AC were instead in Columns B and C, but on the row after. I have the following written which moved the data from B and C to AB and AC respectively:
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("A:A")
i = 1
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For Each rCell In rRng.Cells
If rCell.Value = "" Then
Range("AB" & i) = rCell.Offset(0, 1).Value
rCell.Offset(0, 1).ClearContents
End If
i = i + 1
If i = lastRow + 1 Then
Exit Sub
End If
Next rCell
End Sub
However, it doesn't fix the problem of the data being on the row BELOW the appropriate row now that they are in the right columns. I am new to VBA Macros so I would appreciate any help to make the data now align. I tried toggling the Offset parameter (-1,0) but it's not working.

Try something like this?
For i = Lastrow To 1 Step -1
' move data into cell AA from Cell A one row down
Cells(i, 27).Value = Cells(i + 1, 1).Value
Next

You don't need to loop through the range to accomplish what you're trying to do.
Try this instead:
Sub MoveBCtoAbAcUpOneRow()
Dim firstBRow As Integer
Dim lastBRow As Long
Dim firstCRow As Integer
Dim lastCRow As Long
' get the first row in both columns
If Range("B2").Value <> "" Then
firstBRow = 2
Else
firstBRow = Range("B1").End(xlDown).Row
End If
If Range("C2").Value <> "" Then
firstCRow = 2
Else
firstCRow = Range("C1").End(xlDown).Row
End If
' get the last row in both columns
lastBRow = Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row
lastCRow = Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
' copy the data to the correct column, up one row
Range("B" & firstBRow & ":B" & lastBRow).Copy Range("AB" & firstBRow - 1)
Range("C" & firstCRow & ":C" & lastCRow).Copy Range("AC" & firstCRow - 1)
' clear the incorrect data
Range("B" & firstBRow & ":B" & lastBRow).ClearContents
Range("C" & firstCRow & ":C" & lastCRow).ClearContents
End Sub
Notes:
If the shape of data in each column is the same, you don't need to
find the first and last row for each. You'll only need one variable for each and one copy operation instead of 2.
Make sure you set variable declaration to required.
(Tools -> Options -> Require Variable Declaration) You may already be doing this, but I couldn't tell because it looks like the top of your Sub got truncated.

Related

How to make multiple "for" statements run efficiently in VBA

In my code there is a searching order and it does as folloing:
It takes each value (about 2000 ranges) in ws.sheet range A and looks it up in another sheet named wp.sheet range A (about 90 ranges). If a particular value x in ws.sheet range e.g A3 is not found in wp.sheet range A the next search order in sheet ws.sheet is the value y in the next range B3 (same row as value x) to be searched in sheet wp.sheet in the entire range B, and so on.
This is what my "for" loop does and the issue with my code is that it takes very long as it compares each value in ws.sheet range A1-2000 to the values in wp.sheet range A1-90. Is there an alternative which does it more quickly or more efficiently?
Dim wb As Workbook, wq As Object
Dim ws, wi As Worksheet, datDatum
Dim w As Long, I As Long, t As Long
Dim DefaultMsgBox()
Dim r, i As Integer
For r = 2 To 2000
Check = True:
For i = 1 To 90
If ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
For i = 1 To 90
If ws.Range("B" & r).Value = wp.Sheets("ABC").Range("B" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
For i = 1 To 90
If ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
wp.Sheets("ABC").Rows(i).Columns("E:AB").Copy
ws.Range("G" & r).PasteSpecial
GoTo NextR
End If
Next i
NextR:
If Not Check = ws.Range("A" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("B" & r).Value = wp.Sheets("ABC").Range("A" & i).Value Or Not Check = ws.Range("C" & r).Value = wp.Sheets("ABC").Range("C" & i).Value And ws.Range("D" & r).Value = wp.Sheets("ABC").Range("D" & i).Value Then
MsgBox "......"
End If
Next r
End sub
I would suggest turning off ScreenUpdating and using the Find function instead:
Dim cell, foundValue, lookupRange As Range
Set wp = ThisWorkbook.Sheets("ABC")
Set ws = ThisWorkbook.Sheets("WS")
r = 2
number_r = 2000
ru = 1
number_ru = 90
Application.ScreenUpdating = False
'Loop through each cell in WS, offsetting through columns A to C
For Each cell In ws.Range("A" & r & ":A" & number_r)
For i = 0 To 2
'Define range to look up in ABC
Set lookupRange = wp.Range(wp.Cells(ru, i + 1), wp.Cells(number_ru, i + 1))
'Look for current WS cell on corresponding column in ABC
Set foundValue = lookupRange.Find(cell.Offset(0, i).Value)
'If cell is found in ABC...
If Not foundValue Is Nothing Then
Select Case i
Case 2 'If found cell is in column C
Do 'Lookup loop start
'If same values on columns D...
If foundValue.Offset(0, 1).Value = cell.Offset(0, 3).Value Then
'Copy data to WS and switch to the next cell
wp.Rows(foundValue.Row).Columns("E:AB").Copy
ws.Range("G" & cell.Row).PasteSpecial
GoTo nextCell
'If not same values on columns D...
Else
'Try to find next match, if any
Set foundValue = lookupRange.FindNext(foundValue)
If foundValue Is Nothing Then GoTo noMatchFound
End If
Loop 'Repeat until WS values in column C and D match ABC values in columns C and D
Case Else 'If found cell is in column A or B
'Copy data to WS and switch to the next cell
wp.Rows(foundValue.Row).Columns("E:AB").Copy
ws.Range("G" & cell.Row).PasteSpecial
GoTo nextCell
End Select
End If
Next i
noMatchFound:
MsgBox "......" 'Message appears only when no match was found in column A, column B and column C + D
nextCell:
Next cell
Application.ScreenUpdating = True
I hope you don't mind my saying so, but your code is hard to follow, including your choice of variable names. I can recommend that if you do not make use of your .copy statements, then comment them out and your code will run much faster.

Excel VBA copy multiple lines

I'm trying to copy some data from one Sheet to another using a vba script, it works fine but it doesn't appear to gather all the results, the data i have is split up over multiple tables so i assume it's seeing a blank space and stepping out but i'm not sure the solution! (the results i'm after are all letters i.e A-f and are all located on column C)
code below:
Sub copytoprint()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Application.ScreenUpdating = False
On Error GoTo Err_Execute
LSearchRow = 2
LCopyToRow = 2
While Len(Range("C" & CStr(LSearchRow)).value) > 0
If InStr(1, Range("C" & CStr(LSearchRow)).value, "A") > 0 Then
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Sheets("dest").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
LCopyToRow = LCopyToRow + 1
Sheets("source").Select
End If
LSearchRow = LSearchRow + 1
Wend
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Input would just be a basic line of details i.e
ID person ref itemid itemname shape
Alphas1 bob A As01 Alphaselects1 circle
Alphas2 Stuart B As02 Alphaselects2 circle
Basically they are split up with many records I'd like it to grab all the A reference put them in one table then folow on with B C etc
Hope that makes a little sense?
Looks like you want to search from ActiveSheet using certain reference (A,B,C,,etc) and copy matching rows into unique destination sheets.
Below code will help you accomplish this, it separates the copying sub-procedure out into its own sub (called copyToSheet) and you can keep calling it from copytoprint() each time giving a reference and the destination sheet you desire.
Option Explicit
Private Sub copyToSheet(reference As String, shtSource As Worksheet, shtDest As Worksheet)
Dim x As Integer
Dim y As Integer
shtDest.Range("A2:Z" & shtDest.UsedRange.Rows.Count + 2).ClearContents
x = 2
y = 2
'loop until 20 consequtive rows have column C blank
While (Not shtSource.Range("C" & x).Value = "") _
And (Not shtSource.Range("C" & (x + 1)).Value = "") _
And (Not shtSource.Range("C" & (x + 5)).Value = "") _
And (Not shtSource.Range("C" & (x + 10)).Value = "") _
And (Not shtSource.Range("C" & (x + 20)).Value = "")
'If shtSource.Range("C" & x).Value, reference) > 0 Then
If shtSource.Range("C" & x).Value = reference Then
shtDest.Range("A" & y & ":Z" & y).Value = shtSource.Range("A" & x & ":Z" & x).Value
y = y + 1
End If
x = x + 1
Wend
End Sub
Public Sub copytoprint()
copyToSheet "A", ActiveSheet, Sheets("A")
copyToSheet "B", ActiveSheet, Sheets("B")
MsgBox "All matching data has been copied."
End Sub
So if I understood your problem correctly then you want to sort the data in sheet source first and then paste all of that data in another sheet.
If that's the case try this code.
Sub copytoprint()
Dim lastrow As Double
With Sheets("source")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A2:F" & lastrow).Sort key1:=Range("C3:C" & lastrow), order1:=xlAscending, Header:=xlNo
End With
Sheets("dest").Range("A2:F" & lastrow).Value = Sheets("source").Range("A2:F" & lastrow).Value
End Sub

Move Cells up based on value

I'm kind of struggeling with VBA for excel. I have a table with products, where products can have multiple categories. The categories that are linked to a product can have sub-categories, which are located in the columns next to it. If a product has multiple categories, these categories are located one row below the product. See pic1.
What I want to achieve:
Every time I execute the script, the current categories that are on the row of the product info need to be replaced with the categories below it, until you reach the next product. If there is no new category to replace, the product row can be deleted. (In this example I need to run the script 3 times). So I eventually will end up with this:
Run script first time:
Run script second time:
Run script 3rd time:
The code I've got so far is:
Sub MoveEmpty()
Dim i as Long, j as Long
Application.ScreenUpdating = False
j = Range("A" & Rows.Count).End(xlUp).Row
For i = j to 3 Step -1
If Range("A" & i) <> "" Then
Range("C" & i -1) = Range("C" & i).Resize(,3)
Range("A" & i).EntireRow.Delete
End If
Next i
End Sub
Hope this makes sense, and thanks for helping out,
Bart
You were on the right track, this should do what you want:
Sub MoveEmpty()
Dim i As Long, j As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
' Set this appropriately
Set ws = ThisWorkbook.Worksheets("MyWorksheet")
j = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = j To 3 Step -1
If ws.Range("A" & i) <> "" Then
' Copy the product name to be next to the 2nd category set down, if there is a category
If ws.Range("A" & (i + 1)) = "" And ws.Range("C" & (i + 1)) <> "" Then
' If you just want the values (i.e. no formatting copied)
ws.Range("A" & (i + 1)).Resize(, 2).Value = ws.Range("A" & i).Resize(, 2).Value
' If you want everything, including formats
Call ws.Range("A" & i).Resize(, 2).Copy(ws.Range("A" & (i + 1)).Resize(, 2))
End If
ws.Range("A" & i).EntireRow.Delete
End If
Next i
' Reset the screen to updating
Application.ScreenUpdating = True
End Sub

Vba Lookup value on sheet x if value like or similar to?

I have a workbook with 2 sheets.
Sheet1:
Column B Column C Column D Column E
Dairy Crest Ltd
Milk Farm
Tuna Family
Guiness
Sheet 2:
Column A Column B Column C Column d
Dairy Crest James james#email.com 07874565656
Milk Farm Limited Kelly kely#email.com 07874565656
Tuna's Families Dave dave#email.com 07874565656
Guiness Prep Limited Tom tom#email.com 07874565656
I want to match the similar named companies. This can't be a case of saying if value = value because the company name is usually spelt different.
Instead i want to use like or wildcard. Would this work?
If i use Value Like Value this doesn't seem to work.
Where found, i want to copy the contact name, email and contact number over to sheet 1 in the relevant columns.
For some reason this is not working. Please can someone show me where i am going wrong?
Relevant code:
'Start second loop sequence
With ThisWorkbook.Worksheets(3)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
j2 = 2
For i2 = 1 To LastRow
' === For DEBUG ONLY ===
Debug.Print ThisWorkbook.Worksheets(2).Range("B" & j2).Value
If ThisWorkbook.Worksheets(2).Range("B" & j2).Value = .Range("A" & i2).Value Then ' check if Week No equals the value in "A1"
ThisWorkbook.Worksheets(2).Range("C" & j2).Value = .Range("B" & i2).Value
ThisWorkbook.Worksheets(2).Range("D" & j2).Value = .Range("D" & i2).Value
ThisWorkbook.Worksheets(2).Range("E" & j2).Value = .Range("C" & i2).Value
j2 = j2 + 1
End If
Next i2
End With
'End Second Loop
Full COde:
Option Explicit
Sub LoadWeekAnnouncementsFromPlanner()
Dim WB As Workbook
Dim WB2 As Workbook
Dim i As Long
Dim i2 As Long
Dim j As Long
Dim j2 As Long
Dim LastRow As Long
Dim ws As Worksheet
'Open Planner
'On Error Resume Next
Set WB = Workbooks("2017 Planner.xlsx")
On Error GoTo 0
If WB Is Nothing Then 'open workbook if not open
Set WB = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx", xlUpdateLinksNever, True, Password:="samples")
End If
'Open PhoneBook
'On Error Resume Next
'On Error GoTo 0
' ======= Edit #2 , also for DEBUG ======
With WB.Worksheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
j = 2
For i = 1 To LastRow
' === For DEBUG ONLY ===
Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("I8").Value)
If CInt(ThisWorkbook.Worksheets(1).Range("I8").Value) = .Range("A" & i).Value Then ' check if Week No equals the value in "A1"
ThisWorkbook.Worksheets(2).Range("A" & j).Value = .Range("A" & i).Value
ThisWorkbook.Worksheets(2).Range("B" & j).Value = .Range("N" & i).Value
ThisWorkbook.Worksheets(2).Range("H" & j).Value = .Range("K" & i).Value
ThisWorkbook.Worksheets(2).Range("I" & j).Value = .Range("L" & i).Value
ThisWorkbook.Worksheets(2).Range("J" & j).Value = .Range("M" & i).Value
ThisWorkbook.Worksheets(2).Range("K" & j).Value = .Range("G" & i).Value
ThisWorkbook.Worksheets(2).Range("L" & j).Value = .Range("O" & i).Value
ThisWorkbook.Worksheets(2).Range("M" & j).Value = .Range("P" & i).Value
ThisWorkbook.Worksheets(2).Range("N" & j).Value = .Range("W" & i).Value
ThisWorkbook.Worksheets(2).Range("O" & j).Value = .Range("Z" & i).Value
'Start second loop sequence
With ThisWorkbook.Worksheets(3)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
j2 = 2
For i2 = 1 To LastRow
' === For DEBUG ONLY ===
Debug.Print ThisWorkbook.Worksheets(2).Range("B" & j2).Value
If ThisWorkbook.Worksheets(2).Range("B" & j2).Value = .Range("A" & i2).Value Then ' check if Week No equals the value in "A1"
ThisWorkbook.Worksheets(2).Range("C" & j2).Value = .Range("B" & i2).Value
ThisWorkbook.Worksheets(2).Range("D" & j2).Value = .Range("D" & i2).Value
ThisWorkbook.Worksheets(2).Range("E" & j2).Value = .Range("C" & i2).Value
j2 = j2 + 1
End If
Next i2
End With
'End Second Loop
j = j + 1
End If
Next i
End With
End Sub
Please can someone show me where i am going wrong?
This is a good example how to use Like in VBA. Try it in the console window, to get the answers.
?"Vito6" Like "V?to6"
True
?"Vito6" Like "Vito#"
True
?"Vito6" Like "V*6"
True
?"Vito6" Like "Vit[a-z]6"
True
?"Vito6" Like "Vit[A-Z]6"
False
?"Vito6" Like "Vit[!A-Z]6"
True
?"12 34" Like "## ##"
True
?"12 34" Like "1[0-9] [0-9]4"
True
If there's not a specific reason you need VBA, you could apply the solution that #Cyril gave in his comment to an Excel cell formula on Sheet1.
For example, in Sheet1, Cell F1, you can input:
=LEFT(B1, 4)
'This would return "Dair"
Then, in column A, you could use a nested IF statement:
=IF(F1 = "dair", "Dairy Crest", IF(F1 = "milk", "Milk Farm Limited, IF(F1 = "tuna", "Tuna's Families", IF(F1 = "Guiness", "Guiness Prep Limited", "No match))))
Will try to elaborate on my thought from the comment I left you:
Dim asdf as String
Dim i as Variant
Dim LR as Long
LR = Sheets("Sheet2").Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 to LR 'Sheet1 looks to start on row 3, while Sheet2 looks to start on row2
asdf = Sheets("Sheet1").Cells(i+1,2).Value
If Sheets("Sheet2").Cells(i,1).Value Like "*asdf*" Then 'you left out the asterisks
'true: copy data
Else:
'false: can just be nothing here
End If
Next i
Something similar to that is what I was suggesting. Utilized like operator, as suggested by #DougCoats.
While you can use wildcards to compare strings using the like operator , the explicit parts need to be exact. So
"*Dairy Crest*" like "Dairy Crest Ltd" will work nicely
but "*Tuna Family*" like "Tuna's Families" will not work.
You can try fuzzy lookup for matching for the 2nd scenario. It employs probability into the lookup.
Here is the link to the source code.
https://www.mrexcel.com/forum/excel-questions/195635-fuzzy-matching-new-version-plus-explanation.html
Just one note for fuzzy matching with probability, the matching may not be 100% correct if you set the accuracy % too low. If accuracy is important, then set the accuracy % higher.

How to refer to already found column in a Sheet formula VBA

I have the following VBA problem. I have a code a which finds a column and then it inserts a worksheets formula in another column. The formula contains a reference to the previously found column.
Dim intBB As Integer
Dim rngBB As Range
Dim controlBB As Integer
intBB = 1
Do While Worksheets("Sheet2").Cells(2, intBB) <> ""
If Worksheets("Sheet2").Cells(2, intBB).Value = "BbCode" Then
With Worksheets("Sheet2")
Set rngBB = .Range(.Cells(2, intBB), .Cells(2, intBB))
controlBB = intBB
End With
Exit Do
End If
intBB = intBB + 1
Loop
Worksheets("Sheet2").Range("W3:W2500").Formula = "= _
IF (controlBB="""","""",BDP(controlBB&"" Equity"",""ID_ISIN""))"
However, this does not work. How can I correctly refer to the found column?
Since you have a column number, rather than letter, I'd suggest using R1C1 format:
Worksheets("Sheet2").Range("W3:W2500").FormulaR1C1 = "= _
IF (RC" & controlBB & "="""","""",BDP(RC" & controlBB & "&"" Equity"",""ID_ISIN""))"
This is how I would do it
For i = 3 To 2500
Worksheets("Sheet2").Range("a" & i).Formula = "=IF(" & Cells(i, controlBB).Address & "="""","""",BDP(" & Cells(i, controlBB).Address & " & "" Equity"",""ID_ISIN""))"
Next i