Posts by KjBox

KjBox · Oct 10th 2021

You're welcome

KjBox · Oct 10th 2021

Try this alternative approach, file attached

Code assigned to the button

Code

Option Explicit
Sub DeleteRows()
Dim x, i As Long, ii As Long
With Sheet1.Cells(1).CurrentRegion
x = .Value
For i = 2 To UBound(x, 1)
If Application.CountIf(.Columns(6), x(i, 6)) > 1 Then
ii = i + 1
Do Until ii = UBound(x, 1) + 1
If x(ii, 6) = x(i, 6) And x(ii, 10) + x(i, 10) = 0 Then
x(i, 1) = vbNullString: x(ii, 1) = vbNullString
Exit Do
End If
ii = ii + 1
Loop
End If
Next
.Value = x
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
End With
End Sub

Display More

KjBox · Sep 26th 2021

CurrentRegion stops at an empty row, so the "Record Only" would not be included. Try

Code

Sub DeleteRows()
Dim x, i As Long, lRow As Long
With Sheet1
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
x = .Cells(2, 4).Resize(lRow)
For i = UBound(x, 1) To 1 Step -1
If x(i, 4) = "Record Only" Then
.Rows(i).Resize(16).Delete
End If
Next
End With
End Sub

Display More

KjBox · Sep 26th 2021

Try this

Code

Sub DeleteRows()
Dim x, i As Long
x = Sheet1.Cells(1).CurrentRegion
For i = UBound(x, 1) To 2 Step -1
If x(i, 4) = "Record Only" Then
Sheet1.Rows(i).Resize(16).Delete
End If
Next
End Sub

Display More

KjBox · Sep 20th 2021

Not surprised you were confused by this question, Rory!

Hanes was trying to adapt a bit of VBA I had written for him to suit a couple of changes in the VLOOKUP tables.

The solution he was looking for was:

Code

For i = 2 To .Cells(.Rows.Count, 7).End(xlUp).Row
.Cells(i, lCol) = _
Application.VLookup(Application.VLookup(.Cells(i, 6), r2, 2, 0), r, _
Application.Match(Application.VLookup(.Cells(i, 8), r3, 2, 0), r.Rows(1), 0), 0)
Next

where r, r2 & r3 are Range variables set to 3 different tables in 3 different workbooks. The results are placed in a 4th workbook.

KjBox · Sep 20th 2021

You're welcome.

KjBox · Sep 19th 2021

Like this?

Code

Sub UpdateDestination()
Dim w, x, y, z, i As Long, ii As Long, lRow As Long, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
With Sheet1
lRow = .Cells(.Rows.Count, 9).End(xlUp).Row
x = .Cells(9, 9).Resize(lRow - 8)
ReDim w(1 To UBound(x, 1), 1 To 1)
ReDim z(1 To UBound(x, 1), 1 To 1)
y = .Cells(9, 35).Resize(lRow - 8)
With oDic
For i = 1 To UBound(y, 1)
If y(i, 1) <> "" Then
If Not .exists(y(i, 1)) Then
.Add y(i, 1), x(i, 1)
Else
oDic(y(i, 1)) = oDic(y(i, 1)) + x(i, 1)
End If
ii = ii + 1: z(ii, 1) = x(i, 1): w(ii, 1) = y(i, 1)
End If
Next
End With
End With
Application.EnableEvents = 0
With Sheet24
With .Cells(4, 4)
.Resize(1000).ClearContents
.Resize(UBound(w, 1)) = w
End With
With .Cells(4, 7)
.Resize(1000).ClearContents
.Resize(UBound(z, 1)) = z
End With
With .Cells(7, 11)
.Resize(1000, 2).ClearContents
.Resize(oDic.Count) = Application.Transpose(oDic.keys)
End With
With .Cells(7, 14)
.Resize(1000, 2).ClearContents
.Resize(oDic.Count) = Application.Transpose(oDic.items)
End With
End With
Application.EnableEvents = 1
MsgBox "Destination Sheet successfully updated", , "Completed"
End Sub

Display More

KjBox · Sep 19th 2021

You're welcome.

Do you need it to work automatically? If so what will the trigger be to run the macro? Alternatively you could add a button to the Source sheet and assign the macro to it.

KjBox · Sep 19th 2021

Try this

Code

Option Explicit
Sub UpdateDestination()
Dim w, x, y, z, i As Long, ii As Long, lRow As Long, oDic As Object
Set oDic = CreateObject("scripting.dictionary")
With Sheet1
lRow = .Cells(.Rows.Count, 9).End(xlUp).Row
x = .Cells(9, 9).Resize(lRow - 8)
ReDim w(1 To UBound(x, 1), 1 To 1)
ReDim z(1 To UBound(x, 1), 1 To 1)
y = .Cells(9, 35).Resize(lRow - 8)
With oDic
For i = 1 To UBound(y, 1)
If y(i, 1) <> "" Then
If Not .exists(y(i, 1)) Then
.Add y(i, 1), x(i, 1)
Else
oDic(y(i, 1)) = oDic(y(i, 1)) + x(i, 1)
End If
ii = ii + 1: z(ii, 1) = x(i, 1): w(ii, 1) = y(i, 1)
End If
Next
End With
End With
Application.EnableEvents = 0
With Sheet24
With .Cells(4, 4)
.Resize(1000).ClearContents
.Resize(UBound(w, 1)) = w
End With
With .Cells(4, 7)
.Resize(1000).ClearContents
.Resize(UBound(z, 1)) = z
End With
With .Cells(7, 11)
.Resize(1000, 2).ClearContents
.Resize(oDic.Count) = Application.Transpose(oDic.keys)
End With
.Cells(7, 12).Resize(oDic.Count) = Application.Transpose(oDic.items)
End With
Application.EnableEvents = 1
MsgBox "Destination Sheet successfully updated", , "Completed"
End Sub

Display More

KjBox · Sep 18th 2021

You're welcome.

KjBox · Sep 18th 2021

It is very difficult when your sample files bare no resemblance to your actual file, and you are unable to adapt code that works on your sample file to suit your actual file.

You really need to attach your actual file and explain exactly what it is you need, then those trying to help you will not waste time.

All I could go on was the code you had, which copied Column AH of the Source sheet to Column A of the Destination sheet, I thought you wanted to change that to column D.

Now you want to use Columns I and J in the source file, is that correct?

KjBox · Sep 18th 2021

Thanks for the files you sent.

First you need to change the Input file a bit, replace "Dom Rep" with "Dominican Republic" and replace "Trinidad & Tobago" with "Trinidad and Tobago"

Then change your code to this

Code

Sub Dumyx()
Dim FName, wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim wb2s As Worksheet, rng As Range, r As Range
Dim lRow As Long, lCol As Long, i As Long
FName = Application.GetOpenFilename("excel files,*.csv", , "Select DND Format", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 2 Then
Set wb1 = Workbooks.Open(FName(1))
Set wb2 = Workbooks.Open(FName(2))
Else
MsgBox "Please select DnD format", 16, "Rate Automation - To Update DND format"
Exit Sub
End If
FName = Application.GetOpenFilename("excel files,*.xlsx", , "Select Input", , True)
If Not IsArray(FName) Then Exit Sub
If UBound(FName) = 1 Then
Set wb3 = Workbooks.Open(FName(1))
Else
MsgBox "Please select Input", 16, "Rate Automation - To Update DND format"
Exit Sub
End If
Set rng = wb1.Sheets(1).Range("A1:P1")
Set r = wb3.Sheets(5).[b10].CurrentRegion
Set wb2s = wb2.Sheets(1)
Application.ScreenUpdating = False
With wb1.Sheets(1)
Set delcol = .Cells(1).CurrentRegion.Columns(35).Resize(, 8)
lRow = wb2s.Range("B" & .Rows.Count).End(xlUp).Row
wb2s.Range("A2:A" & lRow).Copy .Range("E2")
wb2s.Range("B2:B" & lRow).Copy .Range("F2")
wb2s.Range("D2:D" & lRow).Copy .Range("H2")
wb2s.Range("ABV2:ABV" & lRow).Copy .Range("B2")
wb2s.Range("ABU2:ABU" & lRow).Copy .Range("C2")
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("D2:D" & lRow).FillDown
.Range("G2:G" & lRow).FillDown
.Range("J2:J" & lRow).FillDown
.Range("K2:K" & lRow).FillDown
lCol = .Rows(1).Find("destination").Column
.Columns(lCol + 1).EntireColumn.Insert Shift:=xlToRight
.Cells(1, lCol + 1) = "Country"
.Cells(2, lCol + 1).Formula = "=VLOOKUP(F2,XFC:XFD,2,0)"
.Range("G2:G" & lRow).FillDown
lCol = .Rows(1).Find("free_time").Column
For i = 2 To .Cells(.Rows.Count, 7).End(xlUp).Row
.Cells(i, lCol) = Application.VLookup(.Cells(i, 7), r, 2, 0)
Next
For Each cel In delcol.Cells
If cel.Value = "Country" Then cel.EntireColumn.Delete
Next
End With
wb2.Close , 0
wb3.Close , 0
End Sub

Display More

KjBox · Sep 18th 2021

The data is in columns D and E. The reason column D is empty is because your sample file has no data in Source Sheet Column AH.

KjBox · Sep 18th 2021

Change

Code

If x(i, 1) <> "" Then

To

Code

If x(i, 2) <> "" Then

KjBox · Sep 18th 2021

Try this

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x, y, i As Long, ii As Long, lRow As Long
If Target.Column = 35 And Target.Row > 8 Then
With Sheet4
lRow = .Cells(Rows.Count, 35).End(xlUp).Row
x = .Range(.Cells(9, 34), .Cells(lRow, 35))
ReDim y(1 To UBound(x, 1), 1 To 2)
End With
For i = 1 To UBound(x, 1)
If x(i, 1) <> "" Then
ii = ii + 1: y(ii, 1) = x(i, 1): y(ii, 2) = x(i, 2)
End If
Next
With Sheet24
lRow = .Cells(Rows.Count, 4).End(xlUp).Row + 1
.Cells(lRow, 4).Resize(UBound(y, 1), 2) = y
End With
End If
End Sub

Display More

The code loads the data from Columns AH & AI of the Source Sheet into array x. Code then loops through array x and builds array y if the second dimension of x is not blank. The code then places the contents of array y onto the Destination sheet.

KjBox · Sep 18th 2021

Try this, the code needs to be placed in the Worksheet Object Module for Sheet4

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x, y, i As Long, ii As Long, lRow As Long
If Target.Column = 35 And Target.Row > 8 Then
With sheet4
lRow = .Cells(Rows.Count, 35).End(xlUp).Row
x = .Range(.Cells(9, 34), .Cells(lRow, 35))
ReDim y(1 To UBound(x, 1), 1 To 2)
End With
For i = 1 To UBound(x, 1)
If x(i, 1) <> "" Then
ii = ii + 1: y(ii, 1) = x(i, 1): y(ii, 2) = x(i, 2)
End If
Next
With Sheets("sheet4")
lRow = .Cells(Rows.Count, 4).End(xlUp).Row + 1
.Cells(lRow, 1).Resize(UBound(y, 1), 2) = y
End With
End If
End Sub

Display More

KjBox · Sep 17th 2021

Thanks Rory, I just got back and was about to post the same solution.

KjBox · Sep 17th 2021

Ok I will check on that later when I get home

Can you attach a sample file

KjBox · Sep 16th 2021

When sorting "00" is treated the same as "0". Assuming you are using whole numbers only then a work-around is to first change the "0"s to "0.1"s, then sort, then change the "0.1"s back to "0"s.

Try replacing the code you have with this

Code

With Sheets("Game_Info")
.Range("F13:F24").Replace "0", "0.1"
With .Sort
.SortFields.Clear
.SortFields.Add2 .Parent.Range("F13:F23"), _
0, 1, DataOption:=1
.SetRange .Parent.Range("B12:H24")
.Header = 1: .Apply
End With
.Range("F13:F24").Replace "0.1", "0"
End With

Display More

KjBox · Sep 14th 2021

You're welcome. Thanks for the "Like".

Posts by KjBox

VBA Macro Macro for deleting rows with same reference and opposite signs

VBA Macro Macro for deleting rows with same reference and opposite signs

VBA Delete Entire Row if Contains Certain Text

VBA Delete Entire Row if Contains Certain Text

Vlookup vba code

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Dynamic Autofill

Automatically Copy But Skip blank cell of a column to another sheet.

Dynamic Autofill

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Automatically Copy But Skip blank cell of a column to another sheet.

Sort numbers stored as text

Sort numbers stored as text

Sort numbers stored as text

Dynamic Autofill