Excel VBA Copy Paste Values with conditions - vba

I'm trying to copy values from one small sheet "MD with ID" to A Larger sheet "D with ID" if 2 fields are identical (consider those two as keys that identify each record).
Here is my first try:
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Here is my second try:
Sub CopyIDCells2()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until j = 20886
d = 2
Do Until d = 1742
If e.Cells(j, 3).Value = i.Cells(d, 4).Value Then
If e.Cells(j, 13).Value = i.Cells(d, 10).Value Then
e.Cells(j, 1).Value = i.Cells(d, 2).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Nothing changes in the excel sheet when this code runs, although it takes few minutes to run -_-".
.. sample was removed

So looking at your first CopyIdCells method, there is only one fix I would make to this - make variable d=2. This has headers at the top of your sample data and you need to start on row 2 just like the other sheet.
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Other than that your formulas look good, you just do not have any data that meets your requirements. Add this column to the bottom of "MD with ID" and you will see your code match.
mouse 10 08 11267 A/J M 823 1/11/2008 1 SC-807 LONG 10/10/2005
Since you are matching on "Case Number" AND "Other ID" there are no items in both sheets that meet this criteria. When you add the row above to "MD with ID", you will see the appropriate ID added to your second sheet on several rows.

Related

Excel String contains string instead of string equals string

Hi my code currently looks like this
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) = "Cinema ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
However sometimes the data i get is not always "Cinema ABC" but just "ABC". So i need my code to search if the data contains "ABC" instead of equals to "Cinema ABC".
Can you guys help me?
Change
If i.Range("A" & j) = "Cinema ABC" Then
to
If InStr(1, i.Range("A" & j), "ABC") Then
Sub Solbjerg()
Set i = Sheets("Samlet")
Set e = Sheets("ABC")
Dim d
Dim j
d = 7
j = 7
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A" & j) like "*ABC" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub
Like, and * works as wildcards

How to merge cell in a column if cell above it has content but itself is blank

Here is what trouble me:
For cells in column P, for example P3, if both P2 & B3 is not blank, but P3 is blank, then merge P2 with P3. And go on next cell in column P until respective cell in column B(for instance: B8) is blank, then stop.
B .... P
1 Monitor Tom
2 Mouse Ann
3 Keyboard
4 Sticker
5 Speaker John
6 Cable
7 Fan Rose
8
So for table above, I want to merge P2:P4 & P5:P6.
I've tried several time with my poor vba skill, but failed...
This code is what I've found in this website, and I've tried to edit it and see if this can solve my problem, but it doesn't work...
Sub Merge()
LR = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To LR
If ActiveSheet.Cells(i, 1).Value <> "" And ActiveSheet.Cells(i + 1, 1).Value = "" And ActiveSheet.Cells(i + 1, 2).Value <> "" Then
u = i + 1
Do While ActiveSheet.Cells(u, 1).Value = "" And ActiveSheet.Cells(u, 2) <> ""
u = u + 1
Loop
ActiveSheet.Range("A" & i & ":A" & (u - 1)).Select
With Selection
.Merge
.BorderAround Weight:=xlMedium
.WrapText = True
'.VerticalAlignment = x1VAlignTop
'.HorizontalAlignment = xlLeft
End With
Sheets(DataSheet).Range("B" & i & ":B" & (u - 1)).BorderAround Weight:=xlMedium
i = u + 1
End If
Next i
End Sub
Try this:
Dim i As Integer, a As String, b As String, c As Integer, d As Integer
i = 11
a = "B"
b = "P"
c = 0
d = 0
While Range(a & i) <> ""
If Range(b & i) = "" Then
If c = 0 And i > 1 Then
c = i - 1
d = 1
Else
d = d + 1
End If
Else
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If
c = 0
d = 0
End If
i = i + 1
Wend
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If

Find Copy and Paste in VBA macro

I am trying to write a macro which search data from one sheet and copy's to another.
But now I have a problem because I want to copy data between two searches and paste the whole data from multiple cells into one single cell.
For example in the above picture my macro:
SEARCH for "--------------" and "*****END OF RECORD"
COPIES everything in between , here example data in row 29 and 30 and from column A,B,C
PASTE all the data from multiple cells A29,B29,C29 and then A30,B30,C30 to single cell in sheet 2 say cell E2.
This pattern is reoccurring in the column A so I want to search for the next occurrence and do all the steps 1,2,3 and this time I will paste it in Sheet2 , cell E3.
Below is the code:
I am able to search my pattern but hard time in giving references to the cells in between those searched patterns and then copying all the data to ONE cell.
x = 2: y = 2: Z = 7000: m = 0: n = 0
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then
Do
For i = m To n
ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z
'Driver's Licence #:Driver's Licence #:Driver's Licence #:
x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub
Considering that the search is working correctly, about the copy thing you just need to do:
Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value
The result will be something like: AIR COO; L DAT; A
--------UPDATE---------
It was hard to understand your code, so I'm write a new one. Basically it's copy what it found on sheet1 to sheet2.
Sub Copy()
Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied
Z = 7000
h = 1
'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z
If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then
If Sheet1.Cells(count, 1).Value <> "" Then
For y = 1 To 3 'In case you need to copy more columns just adjust this for.
Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value
Next y
h = h + 1
End If
Else
MsgBox "END OF RECORD REACHED"
Exit Sub
End If
Next count
End Sub
Maybe I don't get the full idea but this might work for you.
I'm not at all sure what you want to see in the final output, so this is an educated guess:
Sub DenseCopyPasteFill ()
Dim wsFrom, wsTo As Worksheet
Dim ur As Range
Dim row, newRow As Integer
Dim dataOn As Boolean
Dim currentVal As String
dataOn = False
newRow = 3
Set wsFrom = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
Set ur = wsFrom.UsedRange
For row = 1 To ur.Rows.Count
If wsFrom.Cells(row, 1).Value2 = "--------------" Then
dataOn = True
ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
newRow = newRow + 1
dataOn = False
ElseIf dataOn Then
currentVal = wsTo.Cells(newRow, 5).Value2
wsTo.Cells(newRow, 5).Value2 = currentVal & _
wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
wsFrom.Cells(row, 3)
End If
Next row
End Sub
If you can get away without using the Windows clipboard, I would. Instead of copy/paste, here I demonstrated how you can simply add or append a value.
Add this sub:
Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub
Then your for loop should look like this:
For i = m To n
copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i

Create combinations of text and transforming these to binary in VBA

I'm working on a project where I need to combine 6 keywords to the maximum number of combinations. After this is done, I have to transform these combinations to a form of binary.
example:
Word1 = 100000
Word2 = 010000
Word3 = 001000
Word4 = 000100
Word5 = 000010
Word6 = 000001
And a combination could be: (Word1 Word2 Word5) = 110010
My 6 keywords are in column A2:A7.
If this could be done in VBA, it would make my job a lot easier.
Acording to basic math, 6 entries would combine to 64 combinations. I don't need the "blank" combination, why it'll total 63 combinations.
I'm fairly new to coding and have only worked in VBA for a couple of weeks, so I'm hoping that there might be a specialist out there that could help me with this problem.
Update!
This is what I have written so far. It only combines the words once:
Sub combinations()
Dim i As Long, j As Long, k As Long, l As Long, n As Long, m As Long, lr As Long
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
For j = i + 1 To lr
For k = j + 1 To lr
For l = k + 1 To lr
For n = l + 1 To lr
For m = n + 1 To lr
.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) = .Cells(i, 1).Value & " " & .Cells(j, 1).Value & " " & .Cells(k, 1).Value & " " & .Cells(l, 1).Value & " " & .Cells(n, 1).Value & " " & .Cells(m, 1).Value
Next m
Next n
Next l
Next k
Next j
Next i
End With
End Sub
Regards,
Emil
It would be easier to begin with the bitmap representation (BTW it would be best to avoid calling those "binary")
Dim a, b, c, d, e, f, i
i = 1
For a = 0 To 1
For b = 0 To 1
For c = 0 To 1
For d = 0 To 1
For e = 0 To 1
For f = 0 To 1
Cells(i, 1).Value = "'" & a & b & c & d & e & f
i = i + 1
Next f
Next e
Next d
Next c
Next b
Next a

Move an entire row to another sheet if it contains a specified word

I am trying to find a code that would help me move an entire row to another sheet if it contains the word "Processing" the original sheet is called "Output 1" and the sheet where i need to move it to is "Applications" this is the code i found online but its giving me errors-Thanks ( i am not sure what d and j mean since i got it online)
Set i = Sheets("Output 1")
Set e = Sheets("Applications")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("B" & j))
If i.Range("B" & j) = "Processing" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
Does this work?
Sub DoIt()
Dim i As Worksheet, e As Worksheet
Dim d, j
Set i = Sheets("Output 1")
Set e = Sheets("Applications")
d = 1
j = 2
Do Until IsEmpty(i.Range("B" & j))
If i.Range("B" & j) = "Processing" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value
End If
j = j + 1
Loop
End Sub