I'm trying to import cells from another wb. So if cell in wb1 col H matches cell in wb2 col K then wb1 col k and L = wb2 col C and E in match row. Now there may be several matches so I want it to offset to the next column. m and n for next set, o and p for next, and so on.
This is what I have so far:
Private Sub CommandButton1_Click()
Dim rcell As Range, sValue As String
Dim lcol As Long, cRow As Long
Dim dRange As Range, sCell As Range
Dim LastRow As Integer
Dim CurrentRow As Integer
Set ws1 = ThisWorkbook
Set ws2 = Workbooks("Workbook2").Worksheets("Sheet1")
Sheet1LastRow = ThisWorkbook.Sheets("Data").Range("H2:H50000").Value 'Search criteria column
Sheet2LastRow = Workbooks("Workbook2").Worksheets("Sheet1").Range("Q" & Rows.Count).End(xlUp).Row 'Where to look for matches
With Workbooks("Workbook2").Worksheets("Sheet1")
For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow
If ThisWorkbook.Sheets("Data").Range("H").Value = ws2.Cells(i, 11).Value Then
ws2.Cells(i, 11).Value = ThisWorkbook.Sheets("Data").Range("C").Value
ws2.Cells(i, 12).Value = ThisWorkbook.Sheets("Data").Range("E").Value
End If
If InStr(1, ws2.Cells.Value, ws1.Cells.Value) And Trim(ws1.Cells.Value) <> "" Then
rcell.Offset(0, lcol).Value = ws2.Cells.Offset(0, 2).Value
lcol = lcol + 1
End If
Next i
Next j
End With
End Sub
This doesn't work. I basically gave up since I don't know what I'm missing.
I looked for something like this but only found something a Vlookup or Match could do.
You can do it by keeping track of an offset that you shift by two after each match copied. I'll track this in a variable called offs.
Also I suppose that the copying goes from wb2 to wb1 as described in the text, not as "suspected" in the code.
Private Sub CommandButton1_Click()
Dim cel1 As Range, cel2 As Range
For Each cel1 In ThisWorkbook.Sheets("Data").UsedRange.Columns("H").Cells
Dim offs As Long: offs = 3 ' <-- Initial offset, will increase by 2 after each match
For Each cel2 In Workbooks("Workbook2").Worksheets("Sheet1").UsedRange.Columns("K").Cells
If cel1.Value = cel2.Value Then
cel1.offset(, offs).Value = cel2.offset(, -8).Value ' <- wb2(C) to wb1(K)
cel1.offset(, offs + 1).Value = cel2.offset(, -6).Value ' <- wb2(E) to wb1(L)
offs = offs + 2 ' <-- now shift the destination column by 2 for next match
End If
Next
Next
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I have been working on finding a way to add a matching criteria to another workbook almost this day, but I did not find anyway to do it yet. The example scenario is
the following, I have two workbooks (workbookA and workbookB) and each workbook has their own "Country" and "Value" lists. Kindly see sample tables per below.
Workbook("WorkA").Sheet1 Workbook("workB").Sheet1
Country Value Country Value
A 10 B
B 15 D
C 20 E
D 25 A
E 30
F 35
I finished matching value column by the following code:
Sub Test_match_fill_data()
Dim Dict As Object
Dim key As Variant
Dim aCell, bCell As Range
Dim i, j As Long
Dim w1, w2 As Worksheet
Set Dict = CreateObject("Scripting.Dictionary")
Set w1 = Workbooks("workA").Sheets("Sheet1")
Set w2 = Workbooks("workB").Sheets("Sheet1")
i = w1.Cells(w1.Rows.Count, 1).End(xlUp).row
For Each aCell In w1.Range("A6:A" & i)
If Not Dict.exists(aCell.Value) Then
Dict.Add aCell.Value, aCell.Offset(0, 2).Value
End If
Next
j = w2.Cells(w2.Rows.Count, 1).End(xlUp).row
For Each bCell In w2.Range("A6:A" & j)
For Each key In Dict
If bCell.Value = key Then
bCell.Offset(0, 2).Value = Dict(key)
End If
Next
Next
End Sub
What I would like to do is to add some missing countries from "workA" (in this case are countries "C" and "F") and then redo matching process again to gathered all of data. Copy and paste solution is not suit to my case since I have to gather time series data (trade data) and it is possibly that some months my interested country will trade with new partners. I have tried to research on this in several websites and been deep down and adjusted my code with other people's codes as following link:
Dictionary add if doesn't exist, Looping Through EXCEL VBA Dictionary, Optimise compare and match method using scripting.dictionary in VBA, A 'flexible' VBA approach to lookups using arrays, scripting dictionary
Can any potential gurus suggest me the solutions or ideas to deal with this kind of problems? It would be nice if you could explain your reasoning behind the code or any mistake I had made.
Thank you!
With minimal changes to your code:
Sub Test_match_fill_data()
Dim Dict As Object
Dim key As Variant
Dim aCell As Range, bCell As Range
Dim i As Long, j As Long
Dim w1 As Worksheet, w2 As Worksheet
Set Dict = CreateObject("Scripting.Dictionary")
Set w1 = Workbooks("workA").Sheets("Sheet1")
Set w2 = Workbooks("workB").Sheets("Sheet1")
i = w1.Cells(w1.Rows.Count, 1).End(xlUp).row
For Each aCell In w1.Range("A6:A" & i)
Dict(aCell.Value) = aCell.Offset(0, 2).Value
Next
j = w2.Cells(w2.Rows.Count, 1).End(xlUp).row
For Each bCell In w2.Range("A6:A" & j)
If Dict.Exists(bCell.Value) Then
bCell.Offset(0, 2).Value = Dict(bCell.Value)
Dict.Remove bCell.Value
End If
Next
For Each key In Dict
With w2.Cells(w2.Rows.Count, 1).End(xlUp).Offset(1)
.Value = key
.Offset(,2) = Dict(key)
End With
Next
End Sub
while a slightly more condensed version of it could be the following:
Sub Test_match_fill_data()
Dim Dict As Object
Dim key As Variant
Dim cell As Range
Set Dict = CreateObject("Scripting.Dictionary")
With Workbooks("workA").Sheets("Sheet1")
For Each cell In .Range("A6", .Cells(.Rows.count, 1).End(xlUp))
Dict(cell.Value) = cell.Offset(0, 2).Value
Next
End With
With Workbooks("workB").Sheets("Sheet1")
For Each cell In .Range("A6", .Cells(Rows.count, 1).End(xlUp))
If Dict.Exists(cell.Value) Then
cell.Offset(0, 2).Value = Dict(cell.Value)
Dict.Remove cell.Value
End If
Next
For Each key In Dict
With .Cells(.Rows.count, 1).End(xlUp).Offset(1)
.Value = key
.Offset(, 2) = Dict(key)
End With
Next
End With
End Sub
for a "Fast&Furious" code you want massive use of array and dictionaries and limit excel sheet range accesses to the minimum
so the following code is obtained from my last one, but limiting excel sheets range accesses to initial data reading and final data writing, both in "one shot" mode (or nearly)
Sub Test_match_fill_data()
Dim Dict As Object
Dim iItem As Long
Dim workACountries As Variant, workAValues As Variant
Dim workBCountries As Variant, workBValues As Variant
With Workbooks("workA").Sheets("Sheet1")
workACountries = .Range("A6", .Cells(.Rows.count, 1).End(xlUp)).Value
workAValues = .Range("C6:C" & .Cells(.Rows.count, 1).End(xlUp).Row).Value
End With
Set Dict = CreateObject("Scripting.Dictionary")
For iItem = 1 To UBound(workACountries)
Dict(workACountries(iItem, 1)) = workAValues(iItem, 1)
Next
With Workbooks("workB").Sheets("Sheet1")
workBCountries = .Range("A6", .Cells(.Rows.count, 1).End(xlUp)).Value
workBValues = .Range("C6:C" & .Cells(.Rows.count, 1).End(xlUp).Row).Value
End With
For iItem = 1 To UBound(workBCountries)
If Dict.Exists(workBCountries(iItem, 1)) Then
workBValues(iItem, 1) = Dict(workBCountries(iItem, 1))
Dict.Remove workBCountries(iItem, 1)
End If
Next
With Workbooks("workB").Sheets("Sheet1")
.Range("A6").Resize(UBound(workBCountries)).Value = workBCountries
.Range("C6").Resize(UBound(workBCountries)).Value = workBValues
.Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(Dict.count).Value = Application.Transpose(Dict.Keys)
.Cells(.Rows.count, 3).End(xlUp).Offset(1).Resize(Dict.count).Value = Application.Transpose(Dict.Items)
End With
End Sub
I don't think you need to use a dictionary for this - you can just go through every value in Book1, column A, check if it exists in the range in Book2 column A, and if it does, you can port over its corresponding value - if it DOESN'T, add it to the end and bring over its associated value. This is a simple, dynamic solution.
Note the simple use of .Find to return the row position:
Sub Test_match_fill_data()
Dim aCell
Dim i, j As Long, keyrow As Long
Dim w1, w2 As Worksheet
Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet1")
i = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
j = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
For Each aCell In w1.Range("A2:A" & i)
On Error Resume Next
keyrow = w2.Columns("A:A").Find(What:=aCell, LookAt:=xlWhole).Row
On Error GoTo 0
If keyrow = 0 Then
w2.Range("A" & j + 1).Value = aCell
w2.Range("B" & j + 1).Value = aCell.Offset(0, 1).Value
j = j + 1
Else
w2.Range("B" & keyrow).Value = aCell.Offset(0, 1).Value
End If
keyrow = 0
Next
End Sub
I need help to copy and paste a single row for every cell in another column multiple times starting in the second row.
The raw data looks like this
I need it to look like this
ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:="=Sheet2!R2C5:R2C7"
ActiveWorkbook.Names("data1").Comment = "" Range("data1").Copy
Range("B1").Select ActiveCell.Offset(1, 0).Select ActiveCell.PasteSpecial
Here is where I get lost. I am not sure how to loop it down and then keep it going and copy column a down and then the defined range again.
I also tried this:
Dim LastRow As Variant
Dim LastRowA As Variant
Dim Row As Range
Dim i As Integer
With Sheets("Store_Item_copy")
LastRow = .Range("A2" & Row.Count).End(xlUp).Row
End With
Range("A2" & LastRow).Copy
For i = 2 To LastRow
i = i + 1
With Sheets("Store_Item_copy")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
End With
LastRowA.Offset(1, 0).Select
ActiveCell.PasteSpecial
Next i
Here is one way to do it using arrays.
Option Explicit
Public Sub PopulateColumns()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1") 'Change as appropriate
Dim yearArr()
yearArr = wsSource.Range("E2:F" & wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row).Value
Dim storesArr()
storesArr = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value
Dim resultArr()
ReDim resultArr(1 To UBound(storesArr, 1) * UBound(yearArr, 1), 1 To 3)
Dim counter As Long
Dim counter2 As Long
Dim x As Long, y As Long
For x = 1 To UBound(yearArr, 1)
counter2 = counter2 + 1
For y = 1 To UBound(storesArr, 1)
counter = counter + 1
resultArr(counter, 1) = storesArr(y, 1)
resultArr(counter, 2) = yearArr(counter2, 1)
resultArr(counter, 3) = yearArr(counter2, 2)
Next y
Next x
wsSource.Range("A2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
End Sub
Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.
Not really good at VBA here. Found and edited some code that I believe can help me.
I need this code to search 2 columns (L and M) for any string in those columns that ends with _LC _LR etc... Example: xxxxxxxx_LC .
If the cell ends with anything in the array, I need the row to be copied to a new sheet. Here is what I have:
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("L2:L, M2:M" & lngLstRow)
For i = 1 To maxKeywords
If keywords(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("sheet1").Select
Range("L65536, M65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Results").Select
End If
Next i
Next
End Sub
Okay, the issue I think is with your variable declarations. Before I continue, I will echo #GradeEhBacon's comment that if you can't read this and understand what's going on, you may want to take some time to learn VBA before running.
This should work, AFAIK. You didn't specify which sheet has what info, so that may have to be tweaked. Try the below, and let me know what is/isn't working:
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String, maxKeywords() As String
Dim totalKeywords As Integer, i&
Dim ws As Worksheet, resultsWS As Worksheet
Set ws = Sheets("Sheet1")
Set resultsWS = Sheets("Results")
totalKeywords = 6
ReDim keywords(1 To totalKeywords)
ReDim maxKeywords(1 To totalKeywords)
maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"
lngLstRow = ws.UsedRange.Rows.Count 'Assuming "Sheet1" is what you want to get the last range of.
Dim k& ' create a Long to use as Column numbers for the loop
For k = 12 To 13 ' 12 is column L, 13 is M
With ws 'I'm assuming your Ranges are on the "Sheet1" worksheet
For Each rngCell In .Range(.Cells(1, k), .Cells(lngLstRow, k))
For i = LBound(maxKeywords) To UBound(maxKeywords)
If maxKeywords(i) = Right(rngCell.Value, 3) or maxKeywords(i) = Right(rngCell.Value, 2) Then
' rngCell.EntireRow.Copy
' ws.Range("L65536, M65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
resultsWS.Cells(65536, k).End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
End If
Next i
Next rngCell
End With
Next k
End Sub
This might be what you are looking for:
==================================================
Option Explicit
Sub Test()
Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords, i, j, k As Integer
maxKeywords = 6
ReDim keywords(1 To maxKeywords)
keywords(1) = "_LC"
keywords(2) = "_LR"
keywords(3) = "_LF"
keywords(4) = "_W"
keywords(5) = "_R"
keywords(6) = "_RW"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For j = 1 To lngLstRow
For i = 1 To maxKeywords
If keywords(i) = Right(Sheets("Results").Range("L" & j).Value, Len(keywords(i))) Or _
keywords(i) = Right(Sheets("Results").Range("M" & j).Value, Len(keywords(i))) Then
k = k + 1
Rows(j & ":" & j).Copy
Sheets("sheet1").Select
Range("A" & k).Select
ActiveSheet.Paste
End If
Next i
Next j
End Sub