The code below searches and compares the file names between two folders (including subfolders) reporting how many duplicates there are between folders. Subfolder names are identical.
I need to prohibit to comare files from different subfolders. I mean macro should only compare files in subfolders with the same subfolder names even if in other folders there are files with the same file names.
Can anyone help?
Example:
**folder1** **folder2**
first_folder vs first_folder
1.xml 1.xml
2.xml 2.xml
second_folder vs second_folder
1.xml 1.xml
The macro should not search for and compare 1.xml file between first_folder and second_folder. Only files from the same folder name should be compared.
Thank you in advance.
Sub CompareContentsofTwoFolders()
Dim fcount As Variant
Dim pth1 As String, pth2 As String
Dim r1 As Single, r2 As Single
Dim arrd() As Variant
Dim arru() As Variant
ReDim arrd(0 To 5, 0)
ReDim arru(0 To 2, 0)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth1 = .SelectedItems(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth2 = .SelectedItems(1) & "\"
End With
Sheets.Add
Set x = ActiveSheet
Application.ScreenUpdating = False
x.Range("A1") = "Duplicate files"
x.Range("A2") = "Path"
x.Range("B2") = "File name"
x.Range("C2") = "Size"
x.Range("D2") = "Path"
x.Range("E2") = "File name"
x.Range("F2") = "Size"
x.Range("A:F").Font.Bold = False
x.Range("A1:F2").Font.Bold = True
Recursive pth1
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr1 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
Recursive pth2
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr2 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
x.Range("H1") = "Total number of files in Folder 1: " 'Modified No.1
x.Range("I1") = UBound(arr1, 1)
x.Range("H2") = "Total number of files in Folder 2: " 'Modified No.2
x.Range("I2") = UBound(arr2, 1)
For r1 = LBound(arr1, 1) To UBound(arr1, 1)
chk = False
If r1 > 1 Then
If arr1(r1, 2) = arr1(r1 - 1, 2) Then
For r3 = UBound(arrd, 2) To LBound(arrd, 2) Step -1
If arrd(2, r3) <> "" And arrd(1, r3) <> arr1(r1, 2) Then Exit For
If arrd(1, r3) = arr1(r1, 2) Then
If r3 = UBound(arrd, 2) Then ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
arrd(0, r3 + 1) = arr1(r1, 1)
arrd(1, r3 + 1) = arr1(r1, 2)
arrd(2, r3 + 1) = arr1(r1, 3)
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
Exit For
End If
Next r3
For r3 = UBound(arru, 2) To LBound(arru, 2) Step -1
If arru(2, r3) <> "" And arru(1, r3) <> arr1(r1, 2) Then Exit For
If arru(1, r3) = arr1(r1, 2) Then
If r3 = UBound(arru, 2) Then ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
arru(0, r3 + 1) = arr1(r1, 1)
arru(1, r3 + 1) = arr1(r1, 2)
arru(2, r3 + 1) = arr1(r1, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
Exit For
End If
Next r3
GoTo jmp
End If
End If
For r2 = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(r2, 2) = arr1(r1, 2) Then
If chk = False Then
arrd(0, UBound(arrd, 2)) = arr1(r1, 1)
arrd(1, UBound(arrd, 2)) = arr1(r1, 2)
arrd(2, UBound(arrd, 2)) = arr1(r1, 3)
Else
arrd(0, UBound(arrd, 2)) = ""
arrd(1, UBound(arrd, 2)) = ""
arrd(2, UBound(arrd, 2)) = ""
End If
arrd(3, UBound(arrd, 2)) = arr2(r2, 1)
arrd(4, UBound(arrd, 2)) = arr2(r2, 2)
arrd(5, UBound(arrd, 2)) = arr2(r2, 3)
arr2(r2, 1) = ""
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
chk = True
End If
Next r2
If chk = False Then
arru(0, UBound(arru, 2)) = arr1(r1, 1)
arru(1, UBound(arru, 2)) = arr1(r1, 2)
arru(2, UBound(arru, 2)) = arr1(r1, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
End If
jmp:
Next r1
For r2 = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(r2, 1) <> "" Then
arru(0, UBound(arru, 2)) = arr2(r2, 1)
arru(1, UBound(arru, 2)) = arr2(r2, 2)
arru(2, UBound(arru, 2)) = arr2(r2, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
End If
Next r2
x.Range("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = Application.Transpose(arrd)
x.Range("H3") = "Total number of duplicate files: " 'Modified No.3
x.Range("I3") = UBound(arrd, 2)
x.Range("H4") = "Total number of unique files: " 'Modified No.4
x.Range("I4") = UBound(arru, 2)
x.Range("A" & UBound(arrd, 2) + 3) = "Unique files"
x.Range("A" & UBound(arrd, 2) + 4) = "Path"
x.Range("B" & UBound(arrd, 2) + 4) = "File name"
x.Range("C" & UBound(arrd, 2) + 4) = "Size"
x.Range("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).Font.Bold = True
x.Range("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) = Application.Transpose(arru)
Application.ScreenUpdating = True
End Sub
Sub Recursive(FolderPath As String)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
If Right(Value, 4) = ".xml" Then
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = FolderPath
ActiveSheet.Range("B" & Lrow) = Value
ActiveSheet.Range("C" & Lrow) = FileLen(FolderPath & Value)
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Recursive FolderPath & Folder & "\"
Next Folder
End Sub
Related
The following code is supposed to convert or transpose data from multiple rows to lesser rows by IDs
Here's sample of data in Sheet1
And this is the desired output
And here's the code I am trying but I got extra columns and not correct headers
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 2) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 2)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 2
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 2), "1", t - 1)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
I adust the output a little by modifying this line
t = .Item(a(i, 1))(1) + 1
Using Collections
Sub Test2()
Dim ar, dict As Object, k
Dim t As Long, i As Long, r As Long
ar = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ar)
k = ar(i, 1)
If Not dict.exists(k) Then
dict.Add k, New Collection
dict(k).Add ar(i, 3) ' date
End If
dict(k).Add ar(i, 2) ' Item
If dict(k).Count > t Then t = dict(k).Count
Next
ReDim ar(1 To dict.Count + 1, 1 To t + 1)
ar(1, 1) = "ID"
ar(1, 2) = "Date"
For i = 2 To t
ar(1, i + 1) = "MyH " & i - 1
Next
r = 2
For Each k In dict
ar(r, 1) = k
For i = 1 To dict(k).Count
ar(r, i + 1) = dict(k).Item(i)
Next
r = r + 1
Next
With Sheets("Sheet2").Cells(1).Resize(UBound(ar), UBound(ar, 2))
.CurrentRegion.Clear
.Value = ar: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
I have played around the code and could adust the output but I welcome any other solutions
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 3) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 3)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 1
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 3), "1", t - 2)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
a(1, 2) = "Date"
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
first post and also new to VBA so I apologize for anything that is unclear. I have created a code to generate a daily printout of employees, equipment, and subcontractors. The loop is looking for "S" (subcontractors) each day. There is only one day where "S" is present and there are 4 on that day. The issue is that the loop begins correctly and populates the correct information when it finds "S" and lists the 4 separate subcontractors, but every day before and after that it continues to list the first subcontractor even though no "S" is found on those dates. How can I get it to clear that entry if no other "S" are found? I hope that makes sense and I have included the code. Thank you!
Screesnhot
Sub WriteReport_Click()
Dim EachName(1 To 5000) As Variant
Dim NameHours(1 To 5000) As Variant
Dim NamePhase(1 To 5000) As Variant
Dim EquipHours(1 To 5000) As Variant
Dim EquipPhase(1 To 5000) As Variant
Dim EachDate(1 To 5000) As Date
Dim EachEquip(1 To 5000) As Variant
Dim EachSub(1 To 5000) As Variant
Dim SubAmount(1 To 5000) As Variant
Dim i As Long 'loop through records
Dim k As Integer 'count employees
Dim h As Integer 'count equipment
Dim t As Integer 'count subcontractor
Dim m As Integer 'count dates
Dim j As Integer
Dim x As Integer
Dim lr, s, p, StartBorder, EndBorder As Integer 'keeps row counts Start & Finish
Dim TestString As String
Sheets("Data").Activate
k = 1 'counts EachName
h = 1 'counts EachEquip
t = 1 'counts EachSub
m = 1 'counts dates
lr = 1
p = 0
For i = 1 To Rows.Count
If Cells(i, 3) = "L" Then
EachName(1) = Cells(i, 11)
Exit For
End If
Next i
For i = 1 To Rows.Count
If Cells(i, 3) = "E" Then
EachEquip(1) = Cells(i, 12)
Exit For
End If
Next i
For i = 1 To Rows.Count
If Cells(i, 3) = "S" Then
EachSub(1) = Cells(i, 9)
Exit For
End If
Next i
NameHours(1) = 0
EquipHours(1) = 0
EachDate(1) = Cells(1, 1)
SubAmount(1) = 0
Dim LastRow As Integer
For i = 1 To 5000
If EachDate(m) <> Cells(i, 1) Then
m = m + 1 'setting array for next new date
EachDate(m) = Cells(i, 1)
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
StartBorder = lr
Sheets("Report").Cells(lr, 1) = Format(EachDate(m - 1), "mm/dd/yy") 'prints date
Sheets("Report").Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
For j = 1 To k 'prints employees, hours and phase
Sheets("Report").Cells((lr + j), 1) = EachName(j)
Sheets("Report").Cells((lr + j), 2) = NameHours(j)
Sheets("Report").Cells((lr + j), 4) = NamePhase(j)
Sheets("Report").Cells((lr + j), 5).Formula = _
"=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
Next j
k = 1
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
For s = i To 5000 'getting first employee for next date
If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "L" Then
EachName(1) = Cells(s, 11)
Exit For
End If
Next s
Erase NameHours 'clearing manhours for next date
For j = 1 To h
Sheets("Report").Cells((lr + j), 1) = Trim(EachEquip(j))
Sheets("Report").Cells((lr + j), 3) = EquipHours(j)
Sheets("Report").Cells((lr + j), 4) = EquipPhase(j)
Sheets("Report").Cells((lr + j), 5).Formula = _
"=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
Next j
h = 1
For s = i To 5000 'getting first equipment for next date
If Cells(s, 1) = EachDate(m) And Cells(s, 3) = "E" Then
EachEquip(1) = Cells(s, 12)
Exit For
End If
Next s
Erase EquipHours ' clearing equipment hours for next date
lr = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row + 1
For x = 1 To t
Sheets("Report").Cells((lr + x), 1) = EachSub(x)
Sheets("Report").Cells((lr + x), 3) = SubAmount(x)
Next x
For x = i To 5000 'getting subcontractor for next date
If Cells(x, 1) = EachSub(m) And Cells(x, 3) = "S" Then
EachSub(1) = " "
Exit For
End If
Next x
EndBorder = lr + x
t = 1
With Worksheets("Report") 'draws borders
.Range(.Cells(StartBorder, 1), .Cells(EndBorder, 8)).BorderAround ColorIndex:=1, Weight:=xlThick
End With
End If
Select Case Cells(i, 3).Value
Case "L"
If Cells(i, 11) = EachName(k) Then
If Cells(i, 7) = 0 Then
p = p + 1 'adding up per diem
End If
NamePhase(k) = Cells(i, 2)
NameHours(k) = NameHours(k) + Cells(i, 7)
Else
k = k + 1
EachName(k) = Cells(i, 11)
NamePhase(k) = Cells(i, 2)
If Cells(i, 7) = 0 Then
p = p + 1
End If
NameHours(k) = NameHours(k) + Cells(i, 7)
End If
Case "E"
If Cells(i, 12) = EachEquip(h) Then
EquipPhase(h) = Cells(i, 2)
EquipHours(h) = EquipHours(h) + Cells(i, 7)
Else
h = h + 1
EachEquip(h) = Cells(i, 12)
EquipPhase(h) = Cells(i, 2)
EquipHours(h) = EquipHours(h) + Cells(i, 7)
End If
Case "S"
If Cells(i, 9) = EachSub(t) Then
EachSub(t) = Cells(i, 9)
SubAmount(t) = SubAmount(t) + Cells(i, 8)
Else
t = t + 1
EachSub(t) = Cells(i, 9)
SubAmount(t) = SubAmount(t) + Cells(i, 8)
End If
End Select
Next i
MsgBox "Report Completed !!!"
End Sub
You will find your code easier to debug/maintain if you separate the collection of the data and the report generation into 2 discrete steps, preferably in subroutines. For example
Option Explicit
Dim EachName(0 To 5000, 1 To 3) As Variant '1=name 2=hours 3=phase
Dim EachEquip(0 To 5000, 1 To 3) As Variant '1=name 2=hrs 3=phase
Dim EachSub(0 To 5000, 1 To 2) As Variant ' 1=name 2=amount
Dim k As Long 'count employees
Dim h As Long 'count equipment
Dim t As Long 'count subcontractor
Sub WriteReport_Click()
' specify book and sheets to process
Dim wb As Workbook, wsData As Worksheet, wsRep As Worksheet
Set wb = ThisWorkbook ' or ActiveWorkBook
' determine extent of data
Dim LastRow As Long, iRow As Long
Set wsData = wb.Sheets("Data")
LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
' clear report sheet
Set wsRep = wb.Sheets("Report")
wsRep.Cells.Clear
' scan data for first date
Dim RepDate As Date
RepDate = wsData.Cells(1, 1)
Call GetData(RepDate, wsData)
' scan data for more dates
For iRow = 1 To LastRow
If wsData.Cells(iRow, 1) <> RepDate Then
' report existing date
Call ReportData(RepDate, wsRep)
' get data for new date
RepDate = wsData.Cells(iRow, 1)
Call GetData(RepDate, wsData)
End If
Next
' report last date
Call ReportData(RepDate, wsRep)
'end
wsRep.Columns("A:E").AutoFit
MsgBox "Report Completed", vbInformation, LastRow & " rows scanned"
End Sub
Sub ReportData(d As Date, ws As Worksheet)
Debug.Print "ReportData", d
Dim lr As Long, StartBorder As Long, EndBorder As Long, j As Long
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
StartBorder = lr
ws.Cells(lr, 1) = Format(d, "mm/dd/yy") 'prints date
ws.Cells(lr, 1).Interior.ColorIndex = 4 'highlights date
'prints employees, hours and phase
For j = 1 To k
ws.Cells((lr + j), 1) = EachName(j, 1) 'empoyee name
ws.Cells((lr + j), 2) = EachName(j, 2) 'hrs
ws.Cells((lr + j), 4) = EachName(j, 3) 'phase
ws.Cells((lr + j), 5).Formula = _
"=IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",Employee,2,FALSE),"""")"
Next j
' report equipment
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To h
ws.Cells((lr + j), 1) = EachEquip(j, 1) 'equip name
ws.Cells((lr + j), 3) = EachEquip(j, 2) 'hours
ws.Cells((lr + j), 4) = EachEquip(j, 3) 'phase
ws.Cells((lr + j), 5).Formula = _
"=LEFT(IF(A" & CStr(lr + j) & "<>"""",VLOOKUP(A" & CStr(lr + j) & ",EquipList,2,FALSE),""""),20)"
Next j
' report sub contractors
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 1 To t
ws.Cells((lr + j), 1) = EachSub(j, 1) 'sub name
ws.Cells((lr + j), 3) = EachSub(j, 2) 'amount
Next j
' draws borders
EndBorder = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range(ws.Cells(StartBorder, 1), ws.Cells(EndBorder, 8)) _
.BorderAround ColorIndex:=1, Weight:=xlThick
End Sub
Sub GetData(d As Date, ws As Worksheet)
Debug.Print "GetData", d
Dim LastRow As Long, i As Long
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' clear global arrays
Erase EachName
Erase EachEquip
Erase EachSub
k = 0: h = 0: t = 0
For i = 1 To LastRow
If ws.Cells(i, 1) = d Then
Select Case ws.Cells(i, 3)
Case "L" ' Employee
If ws.Cells(i, 11) <> EachName(k, 1) Then
k = k + 1
End If
EachName(k, 1) = ws.Cells(i, 11)
EachName(k, 2) = ws.Cells(i, 7) + EachName(k, 2) ' hours
EachName(k, 3) = ws.Cells(i, 2) ' phase
Case "E" ' Equipment
If ws.Cells(i, 12) <> EachEquip(h, 1) Then
h = h + 1
End If
EachEquip(h, 1) = Trim(ws.Cells(i, 12)) ' equip name
EachEquip(h, 2) = ws.Cells(i, 7) + EachEquip(h, 2) ' hours
EachEquip(h, 3) = ws.Cells(i, 2) ' phase
Case "S" ' Subcontractor
If ws.Cells(i, 9) <> EachSub(t, 1) Then
t = t + 1
End If
EachSub(t, 1) = ws.Cells(i, 9) ' sub name
EachSub(t, 2) = ws.Cells(i, 8) + EachSub(t, 2) ' amount
Case Else
MsgBox "Unknown code at row " & i, vbExclamation
End Select
End If
Next
End Sub
I am checking the value of a checkbox on my userform inside a nested loop. I want to know if there is a way to do this before the loops because basically the code is running the same check over and over again...
what it is doing is it loops through the entire column B and combines all the rows that have the same conditions. then it puts in into an array and prints. So I need to do this checkbox check twice. Any help is appreciated!
Dim dict As Object
Dim LastRow As Long
Dim aCell As Range
Dim ArrayLen As Long
Dim LArr() As Single
Dim MPch As Boolean
MPch = UserForm1.MPCheck1.Value
Set dict = CreateObject("scripting.dictionary")
X = 0
With wks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
ReDim LArr(LastRow)
For Each aCell In .Range("B2:B" & LastRow)
If MPch = True Then
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2)
Else
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2) & "," & aCell.Offset(0, 5)
End If
DieCoordinate = aCell.Value & "," & aCell.Offset(0, 1)
SheetName = aCell.Offset(0, 2) & "-" & aCell.Offset(0, 5)
If Not dict.exists(UniqueCombo) Then
VarLastRow = ThisWorkbook.Worksheets(SheetName).Cells(.Rows.Count, "E").End(xlUp).row + 1
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5) = DieCoordinate
dict(UniqueCombo) = True 'add this value
For o = 2 To LastRow
If MPch = True Then
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4)
Else
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
End If
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
If UniqueCombo = VariableCombo And .Cells(o, 6).Interior.ColorIndex = -4142 And _
.Cells(o, 6) <> "*" And .Cells(o, 6) <> "0" And .Cells(o, 6) <> "" Then
CDTot = CDTot + .Cells(o, 6)
LArr(X) = .Cells(o, 6)
X = X + 1
End If
Next
If X = 0 Then
ArrayLen = 0
Else
ReDim Preserve LArr(UBound(LArr) - (LastRow - X + 1))
ArrayLen = UBound(LArr) - LBound(LArr) + 1
End If
If ArrayLen < UserForm1.TextBox7 Then
ThisWorkbook.Worksheets(SheetName).Range(ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5), ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10)).Interior.ColorIndex = 53
End If
LCDUCD = 3 * Application.WorksheetFunction.StDev_P(LArr)
DieAver = Application.WorksheetFunction.Average(LArr)
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 7) = LCDUCD
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 6) = DieAver
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 8) = aCell.Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 9) = aCell.Offset(0, 1).Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10) = ArrayLen
End If
ReDim LArr(LastRow)
X = 0
Next aCell
End With
I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want
Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub
Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!
Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub
here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub