Posts by jolivanes

jolivanes · 2020-07-08T21:10:28+01:00

Thanks for letting us know.

Very much appreciated.

Good Luck.

If the previous code is too slow, this should be faster.

Code

Sub Or_Maybe_So()
Dim nr As Long, fr As Long, lr As Long, lc As Long, x As Long, a, b, j As Long, i As Long, k As Long
Dim matArr, asgArr, banArr
Dim t
nr = WorksheetFunction.CountA(Columns(2))
ReDim b(1 To nr, 1 To 31)
ReDim matArr(1 To nr, 1 To 4)
ReDim asgArr(1 To nr, 1 To 4)
ReDim banArr(1 To nr, 1 To 5)
fr = 2
lc = 31
x = 0
lr = Cells(Rows.Count, 2).End(xlUp).Row
t = Timer
a = Cells(fr, 1).Resize(lr - 1, lc).Value
For i = LBound(a) To UBound(a)
If Len(a(i, 2)) > 3 Then
x = x + 1
For j = 1 To lc
b(x, j) = a(i, j)
Next j
End If
Next i
For k = 1 To nr
matArr(k, 1) = b(k, 3)
matArr(k, 2) = b(k, 2)
matArr(k, 3) = ""
matArr(k, 4) = b(k, 24)
asgArr(k, 1) = b(k, 3)
asgArr(k, 2) = b(k, 2)
asgArr(k, 3) = b(k, 4)
asgArr(k, 4) = b(k, 5)
banArr(k, 1) = b(k, 3)
banArr(k, 2) = b(k, 2)
banArr(k, 3) = b(k, 7)
banArr(k, 4) = b(k, 9)
banArr(k, 5) = b(k, 31)
Next k
Sheets("Matrah").Cells(3, 2).Resize(UBound(matArr), 4) = matArr
Sheets("ASGBORDRO").Cells(3, 2).Resize(UBound(matArr), 4) = asgArr
Sheets("Banka").Cells(10, 3).Resize(UBound(banArr), 5) = banArr
MsgBox "This macro took " & Format(Round(Timer - t, 2), "00:00:00.00") & " seconds to run."
End Sub

Display More

jolivanes · 2020-07-08T06:14:52+01:00

See Post #2 here:

https://www.excelforum.com/exc…form-with-excel-data.html

jolivanes · Tuesday, 5:18 pm

I've deleted all formulas in "Banka" because the macro will put the info in.

I got rid of the "Merge & Center" in "Banka" row 31 and "ASGBORDRO" row 40.

DO NOT USE MERGE & CENTER. Use Center Across Selection instead.

I've moved "TOPLAM" from "Banka" B31 to F31 and used "Align Text Right" in F31.

jolivanes · Tuesday, 5:11 pm

Code

Sub Maybe()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
Dim c As Range, infoArr(), i As Long
Set sh1 = Sheets("Bordro")
Set sh2 = Sheets("Matrah")
Set sh3 = Sheets("ASGBORDRO")
Set sh4 = Sheets("Banka")
For Each c In sh1.Columns(2).SpecialCells(2)
infoArr = Application.Transpose(Application.Transpose(sh1.Range(sh1.Cells(c.Row, c.Column), sh1.Cells(c.Row, c.Offset(, 29).Column)).Value))
With sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Offset(1)
.Value = infoArr(2)
.Offset(, 1).Value = infoArr(1)
.Offset(, 3).Value = infoArr(23)
End With
With sh3.Cells(sh3.Rows.Count, 2).End(xlUp).Offset(1)
.Value = infoArr(2)
.Offset(, 1).Value = infoArr(1)
.Offset(, 2).Value = infoArr(3)
.Offset(, 3).Value = infoArr(4)
End With
With sh4.Cells(sh4.Rows.Count, 3).End(xlUp).Offset(1)
.Value = infoArr(2)
.Offset(, 1).Value = infoArr(1)
.Offset(, 2).Value = infoArr(6)
.Offset(, 3).Value = infoArr(8)
.Offset(, 4).Value = infoArr(30)
End With
Erase infoArr
Next c
End Sub

Display More

jolivanes · Jun 29th 2020

Thanks for letting us know.

Good luck

jolivanes · Jun 28th 2020

Hi Spencer.

For the ease of reading/copying, could you click on "Forum" at the top and on the pop-up, click on "Forum Rules".

Read #3 about code tags.

Also, if possible, attache a workbook with before and after.

Don't have any personal stuff in it. Change names etc.

jolivanes · Jun 27th 2020

Try

Code

Sub Maybe_B()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long, lr As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
Application.ScreenUpdating = False
codeArr = Range("F3:I" & lr).Value
lengthArr = Range("J3:K" & lr).Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + lr - 2, 2) = lengthArr(i, j)
Next i
k = k + lr - 2
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
Cells(2, 13).Resize(, 5).Value = Array("EB", "Length", "", "EB", "Total")
Range(Cells(2, 13), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(2, 16), Unique:=True
For j = 3 To Cells(Rows.Count, 16).End(xlUp).Row
For i = 3 To Cells(Rows.Count, 13).End(xlUp).Row
If Cells(i, 13).Value = Cells(j, 16).Value Then Cells(j, 16).Offset(, 1).Value = Cells(j, 16).Offset(, 1).Value + Cells(i, 13).Offset(, 1).Value
Next i
Next j
Application.ScreenUpdating = True
End Sub

Display More

jolivanes · Jun 26th 2020

Since you have a very small range, this should do.

Code

Sub Maybe()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long
Application.ScreenUpdating = False
codeArr = Range("F3:I6").Value
lengthArr = Range("J3:K6").Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + 4, 2) = lengthArr(i, j)
Next i
k = k + 4
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
Cells(2, 13).Resize(, 5).Value = Array("EB", "Length", "", "EB", "Total")
Range(Cells(2, 13), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Cells(2, 16), Unique:=True
For j = 3 To Cells(Rows.Count, 16).End(xlUp).Row
For i = 3 To Cells(Rows.Count, 13).End(xlUp).Row
If Cells(i, 13).Value = Cells(j, 16).Value Then Cells(j, 16).Offset(, 1).Value = Cells(j, 16).Offset(, 1).Value + Cells(i, 13).Offset(, 1).Value
Next i
Next j
Application.ScreenUpdating = True
End Sub

Display More

jolivanes · Jun 26th 2020

Glad you got it working and thanks for letting us know,

Appreciated.

jolivanes · Jun 25th 2020

Code

Option Explicit
Sub Maybe()
Dim codeArr, lengthArr, resultArr
Dim k As Long, j As Long, i As Long
codeArr = Range("F3:I6").Value
lengthArr = Range("J3:K6").Value
ReDim resultArr(1 To UBound(codeArr) * 4, 1 To 2)
k = 0
For j = 1 To 4
For i = 1 To UBound(codeArr)
k = k + 1
resultArr(k, 1) = codeArr(i, j)
Next i
Next j
k = 0
For j = 1 To 2
For i = 1 To UBound(lengthArr)
k = k + 1
resultArr(k, 2) = lengthArr(i, j)
resultArr(k + 4, 2) = lengthArr(i, j)
Next i
k = k + 4
Next j
Cells(3, 13).Resize(UBound(resultArr), 2) = resultArr
End Sub

Display More

jolivanes · Jun 24th 2020

sl.no:01

sl.no:5.

sl.no:06

sl.no:7

Are these some secret places? Never heard of these before.

jolivanes · Jun 23rd 2020

Good to hear you're happy.

If you have a period as a trailing character, as you suggested in your first Post (NV.), the "Maybe_1" does not work for that.

Maybe_2 does.

However, Maybe_1 can be changed to take that in consideration.

Good Luck

jolivanes · Jun 22nd 2020

Code

Sub Maybe_1()
Dim lr As Long, lc As Long, i As Long, j As Long
lr = Cells.Find("*", , , , xlByRows, xlPrevious).Row
lc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
For i = 1 To lc
For j = 1 To lr
If Cells(j, i).Value = "NV" Then Cells(j, i).Value = Cells(j, i).Offset(-1).Value / 2 + Cells(j, i).Offset(1).Value / 2
Next j
Next i
End Sub

If all data is numerical with the exception of the "NV" Cells, following should work also.

Code

Sub Maybe_2()
Dim c As Range
For Each c In ActiveSheet.UsedRange.SpecialCells(2, 2)
c.Value = c.Offset(-1).Value / 2 + c.Offset(1).Value / 2
Next c
End Sub

jolivanes · Jun 22nd 2020

Have you requested help on any other forums?

https://www.excelforum.com/exc…ven-the-condition-if.html

jolivanes · Jun 22nd 2020

Code

Sub Maybe()
Dim c As Range
For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Left(c, 2) <> 11 Then c.Value = 11 & Mid(c, 3, 99)
Next c
End Sub
Starts at A2 instead of A1. Change as desired.

jolivanes · Jun 21st 2020

Or without the need for an extra sheet (Sheet H)

See attached

Atilla at Ozgrid.xlsm

jolivanes · Jun 20th 2020

Is this what you mean?

I have not looked at you .bas file.

It assumes that Column C is sorted as you mentioned in your first Post.

You mention "cut all and copy"

You can "Cut and Paste" or "Copy and Paste"

If you don't want to delete the copied range, comment it out (see code).

Code

Sub Maybe()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim firstrw As Long, lastrw As Long
Set sh1 = Worksheets("H")
Set sh2 = Worksheets("B")
firstrw = sh1.Columns(3).Find("Biorganik", , , xlWhole, xlByRows, xlNext).Row
lastrw = sh1.Columns(3).Find("Biorganik", , , xlWhole, xlByRows, xlPrevious).Row
With sh1.Range(sh1.Cells(firstrw, 1), sh1.Cells(lastrw, 1)).Resize(, 10)
.Copy sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Offset(1)
.Delete Shift:=xlUp '<---- Comment this out if not needed
End With
End Sub

Display More

jolivanes · Jun 11th 2020

A Gentleman that goes by ZVI suggested this: (Change as required)

Code

Sub testOpenFile()
Dim varDave
varDave = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If varDave = False Then
MsgBox "No file selected. Cannot continue."
Exit Sub
End If
On Error GoTo exit_
Application.ScreenUpdating = False
With Workbooks.Open(varDave)
'and here the rest of the code
exit_:
Application.ScreenUpdating = True

Display More

jolivanes · Jun 10th 2020

Line will be there to show the frozen range as far as I know.

Select row 4, on the "View" tab, select "Freeze Panes" and "Freeze Panes" again.

jolivanes · Jun 10th 2020

Before we can continue, click on the little down arrow beside "Forum" at the top and select "Forum Rules".

Read and react. In this case, 3A is of importance.

Posts by jolivanes

Transferring line-spaced information to the other page one after another

Fill PDF form from Excel List

Transferring line-spaced information to the other page one after another

Transferring line-spaced information to the other page one after another

How to find a Cell and cut it and all the rows below

Nesting a for each loop within a for next loop

Copy Paste - Columns

Copy Paste - Columns

Copy Paste - Columns

Copy Paste - Columns

Copy Paste - Columns

Replacing a non-numeric value with the average of neighboring cells

Replacing a non-numeric value with the average of neighboring cells

Need help to code VBA Replace value in the cell given the condition IF

Need help to code VBA Replace value in the cell given the condition IF

How to find a Cell and cut it and all the rows below

How to find a Cell and cut it and all the rows below

GetOpenFile window

How to remove unwanted vertical & Horizontal lines

Copy, Find and Paste Values