Column B9:B65 has a combobox in Sheet 1 that has values between A1 to K3 and L1 to W2 that a user can select from.
For example, the user can select values from A1,A2,A3,B1,B2,B3,.....,K1,K2,K3,L1,L2,M1,M2,N1,N2,O1,O2,.......,V1,V2,W1 and W2.
Not necessary be in sequence. Can be in any order but will always be between A1 to W2.
The data for this is in Sheet 2 in Column B2:B56.
My requirement is to have 2 separate buttons to clear contents of column B in Sheet 1.
First button should clear values A1 to K3 from any where in column B9:B65 in sheet 1
Second button should clear values L1 to W2 from any where in column B9:B65 in sheet 1
For First button, I wrote the code below referring google, as I am new to VBA.
'Define variables that are to be used in the program
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LastRow As Long, ws2LastRow As Long, x As Long
Dim ws2Rng As Range
Dim wsf As WorksheetFunction: Set wsf = Application.WorksheetFunction
Dim strData As String
'Set ws1 and ws2 variable to the respective worksheets.
Set ws1 = ThisWorkbook.Worksheets(1)
Set ws2 = ThisWorkbook.Worksheets(2)
'Assign values to ws1LastRow and ws2LastRow
ws1LastRow = ws1.Range("B" & Rows.Count).End(xlUp).Row
ws2LastRow = 34 'Hardcoded as A1 to K3 is in between B2:B34
'To display values assigned to the variables use Debug.Print and get the results displayed in Immediate Window that gets populated using 'Ctrl+G'
Debug.Print ws1LastRow
Debug.Print ws2LastRow
'Set ws2Rng with the range from ws2 sheet that you want to compare
Set ws2Rng = ws2.Range("B2:B" & ws2LastRow)
For x = 9 To ws1LastRow
On Error Resume Next 'To avoid 1004 error.
ws1.Range("B" & x).value = wsf.VLookup(ws1.Range("B" & x).value, ws2Rng, 2, 0)
'Used for Debugging
'strData = Join(wsf.Transpose(ws2Rng.value), ",")
'Debug.Print strData
If (ws1.Range("B" & x).value = wsf.VLookup(ws1.Range("B" & x).value, ws2Rng, 2, False)) Then
ws1.Range("B" & x).ClearContents ' I have to figure out a way to clearcontents of row 'B & x : K &
x' with single line operation.
'Debug.Print x
End If
Next x
End Sub
I want to clear content with single line such as ws1.Range("B" & x : "K" & x).ClearContents I am sure there is no such syntax but this is to give an idea of what I want to attain. Please suggest alternatives if any.
Debugging above code using F8, I found ws1.Range("B" & x).value = wsf.VLookup(ws1.Range("B" & x).value, ws2Rng, 2, 0) line Vlookup returns empty value so ws1.Range("B" & x).value = empty
I am stuck here and looking for a reason as to why my code doesn't work.
If there is more efficient way that meets the requirements, I will be more than happy to implement it. But at the same time I am curious to know the fault in this code.
Related
I try to perform VlookUp using VBA. Specifically I want to find Open prices for each Date (picture attached). But my code fails to find any matches. I Guess i have messed up ranges for vlookup but I cannot find the mistake.
Sub VlookUp()
Dim goalsWs As Worksheet, dataWs As Worksheet
Dim goalsLastRow As Long, dataLastRow As Long, x As Long
Dim dataRng As Range
Set goalsWs = ThisWorkbook.Worksheets("[FULL_TABLE][1]")
Set dataWs = ThisWorkbook.Worksheets("BTC-USD")
goalsLastRow = goalsWs.Range("A" & Rows.Count).End(xlUp).Row
dataLastRow = dataWs.Range("A" & Rows.Count).End(xlUp).Row
Set dataRng = dataWs.Range("A2:G" & dataLastRow)
For x = 2 To goalsLastRow
On Error Resume Next
goalsWs.Range("B" & x).Value = Application.WorksheetFunction.VlookUp( _
goalsWs.Range("A" & x).Value, dataRng, 4, False)
Next x
End Sub
I want to find Open prices from BTC-USD for each Date in FULL_TABLE
The problem was in the data type " the Excel worksheet function gets confused with the array of VBA dates which are always US-centric.
As suggested convert the dates to intrinsic values which you can do simply with the Value2 property, eg x = Range("Source").Value2"
So simply adding (2) after (value) has fixed the problem
goalsWs.Range("A" & x).Value2, dataRng, 4, False)
Wondering if it's possible to use a second workbook as a table to grab matching data similar to a vlookup without using the formula.
Example:
Workbook 1 I want to fill in Column R (Port Code) by looking at Column S (Port City) by using Workbook 2 which has a list of Cities in column D and the Port code I want to fill in workbook 1 in column A.
I know I could use a Vlookup but trying to avoid doing that if I can.
I was thinking of something like this but this only appears to look at the first line of the second worksheet. Any help or push in the right direction would be appreciated.
Dim lr As Long, lr1 As Long, i As Long
Dim LineMaster As Workbook
Dim ls As Worksheet
Dim di As Workbook
Dim td As Worksheet
Set td = di.Worksheets(1)
Set ls = LineMaster.Worksheets(1)
lr = ls.Range("I" & ls.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ls.Range("S" & i).Value Like "" Then
ls.Range("R" & i).Value = ""
ElseIf ls.Range("N" & i).Value = Left(td.Range("D" & i).Value, 4) Then
ls.Range("N" & i).Value = td.Range("A" & i).Value
Else
End If
Next i
Not sure I completely understood your request, but I think you want to do a partial search. In this case, the Instr might be helpful.
I don't think using two workbooks is useful but let's do it your way. Here's what I would go with:
Sub PartialSearch()
Dim lr As Long, lr1 As Long, i As Long, j As Long
Dim lr2 As Long
Dim LineMaster As Workbook
Dim ls As Worksheet
Dim di As Workbook
Dim td As Worksheet
Set LineMaster = ThisWorkbook 'Workbook to fill
Set ls = LineMaster.Worksheets(1) 'Worksheet to fill
Set di = Workbooks.Open(your_workbook) 'Indicate the path of the workbook
Set td = di.Worksheets(1)
lr = ls.Range("S" & ls.Rows.Count).End(xlUp).Row 'Last row of the column S (where cities are already mentioned)
lr2 = td.Range("D" & di.Rows.Count).End(xlUp).Row
For i = 2 To lr
For j = 2 To lr2
If ls.Range("R" & i).Value = "" Then 'If the cell in column R is empty
If InStr(1, ls.Range("S" & i).Value, td.Range("D" & j).Value) > 0 Then 'Then the macro looks for a partial search in the other workbook
ls.Range("R" & i).Value = td.Range("A" & j).Value 'If the value is found, then the port code is written (change the column A if needed)
End If
End If
Next j
Next i
End Sub
Depending on the size of your workbook, this approach might not be the most effective. If it's too time consuming, you could go with .Find.
Intended Result
If a row in a table contains any of the listed strings in column L on Sheet1, Then copy the entire row from Sheet1 and paste the row into a duplicate table on Sheet2 (which would be blank at the beginning).
(UNINTERESTED, UNRELATED, UNDECIDED, etc...)
Then delete the entire row that was transferred from sheet 1.
After macro runs, the new transfers should not reset table on Sheet2, rather add rows on the pre-existing lines. This document would be utilized over months.
Variables
Sheet1 is named Pipeline_Input
Sheet2 is named Closed_Sheet
Sheet1 table is named tblData
Sheet2 table is named tblClosed
Images
Image 1 is the code with error
Image 2 is Sheet 1 with some picture explanation
Image 3 is Sheet 2 with some picture explanation
Current Result
Run-time error '1004':
Application-defined or object-defined error
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_input As Worksheet 'where is the data copied from
Dim Closed_Sheet As Worksheet 'where is the data pasted to
Dim strPhase() As String
Dim i As Integer
Dim intPhaseMax As Integer
Dim lngLstRow As Long
Dim rngCell As Range
Dim finalrow As Integer
Dim lr As Long 'row counter
Dim Looper As Integer
intPhaseMax = 6
ReDim strPhase(1 To intPhaseMax)
strPhase(1) = "LOST"
strPhase(2) = "BAD"
strPhase(3) = "UNINTERESTED"
strPhase(4) = "UNRELATED"
strPhase(5) = "UNDECIDED"
strPhase(6) = "BUDGET"
'set variables
Set Pipeline_input = Sheet1
Set Closed_Sheet = Sheet2
lr = Range("A" & Rows.Count).End(xlUp).Row
For Looper = LBound(strPhase) To UBound(strPhase)
For i = lr To 6 Step -1
Next
If Not Sheet1.Range("L9:L300" & lngLstRow).Find(strPhase(Looper), lookat:=xlWhole) Is Nothing Then
Range(Cells(i, 1), Cells(i, 20)).Copy
Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
Range(Cells(i, 1), Cells(i, 20)).Delete
End If
Next
Sheet2.Select
Sheet2.columns.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Okay, there were a plethora of issues with the code you posted, but I decided to help you out here - Notice a few things - There's no copying and pasting here - we're just transferring data.
Secondly, use easy to understand variables. lr and lngLastRow can't be distinguished from one another, so classify them by which worksheet you're getting that value from.
We create an array in one fell swoop here - Just declare a variant and place our values in. ARRAYS (TYPICALLY) START AT ZERO, NOT ONE, so our loop starts at 0 :). Again, this is what's known as best practice...
I swapped out Looper for j. Again, keep. it. simple!
EDIT: I tested this code out on a simulated workbook and it worked fine - should run into no issues for you either.
EDIT2: Also, always use Option Explicit!
Option Explicit
Sub closedsheet()
Application.ScreenUpdating = False
Dim Pipeline_Input As Worksheet 'source sheet
Dim Closed_Sheet As Worksheet 'destination sheet
Dim i As Long, j As Long, CSlastrow As Long, PIlastrow As Long
Dim strPhase As Variant
'Here we create our array
strPhase = Array("LOST", "BAD", "UNINTERESTED", "UNRELATED", "UNDECIDED", "BUDGET")
'Assign worksheets
Set Pipeline_Input = ActiveWorkbook.Worksheets("Pipeline_Input")
Set Closed_Sheet = ActiveWorkbook.Worksheets("Closed_Sheet")
PIlastrow = Pipeline_Input.Range("A" & Rows.Count).End(xlUp).Row
For j = 0 To UBound(strPhase)
For i = PIlastrow To 6 Step -1
If Pipeline_Input.Range("L" & i).Value = strPhase(j) Then
'Refresh lastrow value
CSlastrow = Closed_Sheet.Range("A" & Rows.Count).End(xlUp).Row
'Transfer data
Closed_Sheet.Range("A" & CSlastrow + 1 & ":S" & CSlastrow + 1).Value = _
Pipeline_Input.Range("A" & i & ":S" & i).Value
'Delete the line
Pipeline_Input.Range("A" & i & ":S" & i).EntireRow.Delete
End If
Next i
Next j
Closed_Sheet.Select
Closed_Sheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
I am looking to save the vertically saved Information for each ID (row 1) from this Worksheet:
To another Worksheet, which Looks like this:
For each column, with the ID in row 1, there are skills saved as strings. Each part (there are 3) is supposed to be saved on the second Worksheet in column B,C and D, respectively.
With the code I will post below, there is no Error. It simply doesn't do anything. When using a stop in the code, the problem seems to be that the items ID's I am trying to find (FindIDcol, FindIDrow) are simply "Nothing".
I am very new to VBA and might have a way too complicated Approach or ineffective code. However, I hope one of you can help me out here.
Thank you in advance for your help!
Here my code:
Dim wsInput As Worksheet
Set wsInput = ActiveWorkbook.Worksheets("Supplier Skills")
Dim wsOutput As Worksheet
Set wsOutput = ActiveWorkbook.Worksheets("Search Skills")
Dim IDcolumn As Range
Dim IDrow As Range
Dim lastcol As Integer
Dim lastRow As Integer
Dim NextRow As Integer
Dim FindIDcol As Range
Dim FindIDrow As Range
With wsInput
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(Cells(1, lastcol).Address(True, False), "$")(0)
'For every column on Input-Sheet with Data
For Each IDcolumn In wsInput.Range("A1:" & LastColLetter & "1")
'Firstly, find each ID column
FindIDcol = wsInput.Range("A1:" & LastColLetter & "1").Find(What:=IDcolumn, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FindIDcol Is Nothing Then
'Secondly, get the respective column Letter
IDcolLetter = Split(FindIDcol.Address, "$")(0)
'Thirdly, find all skills saved in rows beneath this column
lastRow = .Range(IDcolLetter & .Rows.Count).End(xlUp).row
For Each IDrow In wsInput.Range(IDcolLetter & "1:" & IDcolLetter & lastRow)
'Fourthly, get the respective row-number for each skill
FindIDrow = wsInput.Range(IDcolLetter & "2:" & IDcolLetter & lastRow).Find(What:=IDrow, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
IDrowNumber = Split(FindIDrow.Address, "$")(1)
'Fifthly, split the strings in 3 parts
Dim myElements() As String
myElements = Split(wsInput.Range(IDcolLetter & IDrowNumber).value, "\")
'Sixthly, for every skill of that supplier, copy the ID in A, CG in B, Category in C and Product in D
NextRow = wsOutput.Range("A" & Rows.Count).End(xlUp).row + 1
wsInput.Range(IDcolLetter & "1").Copy Destination:=wsOutput.Range("A" & NextRow) 'ID
wsOutput.Range("B" & NextRow) = myElements(0) 'Commodity Group
wsOutput.Range("C" & NextRow) = myElements(1) 'Category
wsOutput.Range("D" & NextRow) = myElements(2) 'Product
Next IDrow
End If
Next IDcolumn
End With
standing your shown data structure and if I correctly interpreted your goal, you can simplify your code as follows:
Option Explicit
Sub main()
Dim wsOutput As Worksheet
Dim colCell As Range, rowCell As Range
Dim outputRow As Long
Set wsOutput = Worksheets("Output") '<--| change "Output" to your actual output sheet name
outputRow = 2 '<--| initialize output row to 2 (row 1 is for headers)
With Worksheets("Input") '<--| reference input sheet (change "Input" to your actual input sheet name)
For Each colCell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(XlCellType.xlCellTypeConstants) '<--| iterate over its row 1 non blank cells
For Each rowCell In .Range(colCell.Offset(1), colCell.End(xlDown)) '<--| iterate over current column rows from row 2 down to last contiguous non empty one
wsOutput.Cells(outputRow, 1) = colCell.Value '<--| write ID in column 1 of current output row
wsOutput.Cells(outputRow, 2).Resize(, 3) = Split(rowCell.Value, "\") '<--| write other info from column 2 rightwards of current output row
outputRow = outputRow + 1 '<--| update output row
Next rowCell
Next colCell
End With
End Sub
should you deal with input sheet non contiguous data below any ID (blank cells) or ID with no data below, there would be needed a few changes
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub